packages feed

haskell-language-server 2.6.0.0 → 2.7.0.0

raw patch · 1000 files changed

+40738/−674 lines, 1000 filesdep +Cabal-syntaxdep +Diffdep +apply-refactdep −asyncdep −base16-bytestringdep −binarydep ~basedep ~extradep ~ghcidePVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal-syntax, Diff, apply-refact, array, dlist, floskell, foldl, fourmolu, fuzzy, ghc-boot, ghc-exactprint, ghc-lib-parser, ghc-lib-parser-ex, hie-compat, hlint, megaparsec, mod, ormolu, parser-combinators, process-extras, refact, regex-applicative, retrie, semigroupoids, stan, stm-containers, stylish-haskell, syb, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, template-haskell, text-rope, time, trial, unliftio, vector

Dependencies removed: async, base16-bytestring, binary, cryptohash-sha1, ghc-paths, ghcide-test-utils, gitrev, hls-alternate-number-format-plugin, hls-cabal-fmt-plugin, hls-cabal-plugin, hls-call-hierarchy-plugin, hls-change-type-signature-plugin, hls-class-plugin, hls-code-range-plugin, hls-eval-plugin, hls-explicit-fixity-plugin, hls-explicit-imports-plugin, hls-explicit-record-fields-plugin, hls-floskell-plugin, hls-fourmolu-plugin, hls-gadt-plugin, hls-hlint-plugin, hls-module-name-plugin, hls-ormolu-plugin, hls-overloaded-record-dot-plugin, hls-pragmas-plugin, hls-qualify-imported-names-plugin, hls-refactor-plugin, hls-rename-plugin, hls-retrie-plugin, hls-semantic-tokens-plugin, hls-splice-plugin, hls-stan-plugin, hls-stylish-haskell-plugin

Dependency ranges changed: base, extra, ghcide, hiedb, hls-graph, hls-plugin-api, hls-test-utils, lsp, lsp-types, mtl, regex-tdfa, unordered-containers

API changes (from Hackage documentation)

Files

ChangeLog.md view
@@ -1,10 +1,187 @@ # Changelog for haskell-language-server +## 2.7.0.0++- Bindists for GHC 9.8.2+  - Enable many more plugins, making GHC 9.8.2 fully supported+- Fix refactor code actions for vim+- Preserve HLint's diagnostic severity+- Many other bug fixes.++### Pull Requests++- Enable pedantic for remaining plugins+  ([#4091](https://github.com/haskell/haskell-language-server/pull/4091)) by @jhrcek+- Add support for fourmolu 0.15+  ([#4086](https://github.com/haskell/haskell-language-server/pull/4086)) by @brandonchinn178+- refactor plugin: fix regex for extracting import suggestions+  ([#4080](https://github.com/haskell/haskell-language-server/pull/4080)) by @jhrcek+- Bump to hiedb 0.6.0.0+  ([#4077](https://github.com/haskell/haskell-language-server/pull/4077)) by @jhrcek+- ghcide: Only try `stat`ing a core file after we ensure it actually exists+  ([#4076](https://github.com/haskell/haskell-language-server/pull/4076)) by @wz1000+- Fix small typo in Retrie error message+  ([#4075](https://github.com/haskell/haskell-language-server/pull/4075)) by @iustin+- add Method_TextDocumentSemanticTokensFullDelta+  ([#4073](https://github.com/haskell/haskell-language-server/pull/4073)) by @soulomoon+- Fix -Wall in retrie plugin+  ([#4071](https://github.com/haskell/haskell-language-server/pull/4071)) by @jhrcek+- Fix -Wall in qualified imported names plugin+  ([#4070](https://github.com/haskell/haskell-language-server/pull/4070)) by @jhrcek+- benchmarks: switch from deprecated haskell/actions/setup to haskell-actions/setup+  ([#4068](https://github.com/haskell/haskell-language-server/pull/4068)) by @jhrcek+- Bump pre-commit/action from 3.0.0 to 3.0.1+  ([#4066](https://github.com/haskell/haskell-language-server/pull/4066)) by @dependabot[bot]+- Fix -Wall in refactor plugin+  ([#4065](https://github.com/haskell/haskell-language-server/pull/4065)) by @jhrcek+- Redundant imports/exports: use range only to determine which code actions are in scope+  ([#4063](https://github.com/haskell/haskell-language-server/pull/4063)) by @keithfancher+- Bump haskell-actions/setup to get GHC 9.6.4 in CI+  ([#4062](https://github.com/haskell/haskell-language-server/pull/4062)) by @jhrcek+- Enable pedantic for more components+  ([#4061](https://github.com/haskell/haskell-language-server/pull/4061)) by @jhrcek+- stack CI: switch to offic. haskell images, bump to lts-22.9 (ghc 9.6.4)+  ([#4060](https://github.com/haskell/haskell-language-server/pull/4060)) by @jhrcek+- Improve hls class plugin test+  ([#4059](https://github.com/haskell/haskell-language-server/pull/4059)) by @soulomoon+- Bump ghcide-test-utils to 2.0.0.0+  ([#4058](https://github.com/haskell/haskell-language-server/pull/4058)) by @wz1000+- Promote more warnings to errors in ghcide+  ([#4054](https://github.com/haskell/haskell-language-server/pull/4054)) by @jhrcek+- Add -Wunused-packages to common warnings+  ([#4053](https://github.com/haskell/haskell-language-server/pull/4053)) by @jhrcek+- Bump lsp versions+  ([#4052](https://github.com/haskell/haskell-language-server/pull/4052)) by @michaelpj+- Optimize semantic token extraction logic+  ([#4050](https://github.com/haskell/haskell-language-server/pull/4050)) by @soulomoon+- Fix warnings in hls-graph, enable pedantic in CI+  ([#4047](https://github.com/haskell/haskell-language-server/pull/4047)) by @jhrcek+- Fix -Wredundant-constraints+  ([#4044](https://github.com/haskell/haskell-language-server/pull/4044)) by @jhrcek+- Disable caching job with ghc 9.2 on windows+  ([#4043](https://github.com/haskell/haskell-language-server/pull/4043)) by @jhrcek+- fix token omitting problem if multiple tokens are connected.+  ([#4041](https://github.com/haskell/haskell-language-server/pull/4041)) by @soulomoon+- Set test options via cabal.project+  ([#4039](https://github.com/haskell/haskell-language-server/pull/4039)) by @michaelpj+- Fix document version test in hls-class-plugin+  ([#4038](https://github.com/haskell/haskell-language-server/pull/4038)) by @July541+- Fix -Wunused-imports+  ([#4037](https://github.com/haskell/haskell-language-server/pull/4037)) by @jhrcek+- Use GHC2021+  ([#4033](https://github.com/haskell/haskell-language-server/pull/4033)) by @michaelpj+- Remove ghcide-test-utils as a separate package+  ([#4032](https://github.com/haskell/haskell-language-server/pull/4032)) by @michaelpj+- Fix weird behavior of OPTIONS_GHC completions (fixes #3908)+  ([#4031](https://github.com/haskell/haskell-language-server/pull/4031)) by @jhrcek+- semantic tokens: add infix operator+  ([#4030](https://github.com/haskell/haskell-language-server/pull/4030)) by @soulomoon+- fix: a typo in docs/configuration.md+  ([#4029](https://github.com/haskell/haskell-language-server/pull/4029)) by @kkweon+- Turn off tasty-rerun+  ([#4028](https://github.com/haskell/haskell-language-server/pull/4028)) by @michaelpj+- Reduce the number of ad-hoc helper test functions in refactor plugin tests+  ([#4027](https://github.com/haskell/haskell-language-server/pull/4027)) by @jhrcek+- Fix documentation/image links+  ([#4025](https://github.com/haskell/haskell-language-server/pull/4025)) by @jhrcek+- Fix various issues+  ([#4024](https://github.com/haskell/haskell-language-server/pull/4024)) by @michaelpj+- Use relative file paths for HIE files and Stan's config maps+  ([#4023](https://github.com/haskell/haskell-language-server/pull/4023)) by @keithfancher+- fix isClassNodeIdentifier in hls-class-plugin+  ([#4020](https://github.com/haskell/haskell-language-server/pull/4020)) by @soulomoon+- Fix -Wall and -Wunused-packages in hlint plugin+  ([#4019](https://github.com/haskell/haskell-language-server/pull/4019)) by @jhrcek+- update hlint to 3.8 and prevent linting on testdata dir+  ([#4018](https://github.com/haskell/haskell-language-server/pull/4018)) by @soulomoon+- refactor plugin: add reproducer and fix for #3795+  ([#4016](https://github.com/haskell/haskell-language-server/pull/4016)) by @jhrcek+- Fix -Wall and -Wunused-packages in stylish-haskell plugin+  ([#4015](https://github.com/haskell/haskell-language-server/pull/4015)) by @jhrcek+- Fix -Wall and -Wunused-packages in stan plugin+  ([#4014](https://github.com/haskell/haskell-language-server/pull/4014)) by @jhrcek+- fix doc for semantic token+  ([#4011](https://github.com/haskell/haskell-language-server/pull/4011)) by @soulomoon+- Fix -Wall and -Wunused-packages in module name and overloaded record dot plugins+  ([#4009](https://github.com/haskell/haskell-language-server/pull/4009)) by @jhrcek+- Fix -Wall and -Wunused-package in gadt plugin+  ([#4008](https://github.com/haskell/haskell-language-server/pull/4008)) by @jhrcek+- Fix -Wall and -Wunused-packages in fourmolu and ormolu plugins+  ([#4007](https://github.com/haskell/haskell-language-server/pull/4007)) by @jhrcek+- Fix -Wall and -Wunused-packages in plugins api and floskell+  ([#4005](https://github.com/haskell/haskell-language-server/pull/4005)) by @jhrcek+- Fix -Wunused-packages in test utils+  ([#4004](https://github.com/haskell/haskell-language-server/pull/4004)) by @jhrcek+- Update base lower bounds for HLS+  ([#4000](https://github.com/haskell/haskell-language-server/pull/4000)) by @fendor+- Various 9.8 compat+  ([#3998](https://github.com/haskell/haskell-language-server/pull/3998)) by @michaelpj+- Fix -Wall and -Wunused-packages in explicit-record-fields plugin+  ([#3996](https://github.com/haskell/haskell-language-server/pull/3996)) by @jhrcek+- Fix -Wall and -Wunused-packages in explicit fixity plugin+  ([#3995](https://github.com/haskell/haskell-language-server/pull/3995)) by @jhrcek+- Remove an allow-newer+  ([#3989](https://github.com/haskell/haskell-language-server/pull/3989)) by @michaelpj+- chore: Fix typo s/occured/occurred+  ([#3988](https://github.com/haskell/haskell-language-server/pull/3988)) by @hugo-syn+- Update support tables+  ([#3987](https://github.com/haskell/haskell-language-server/pull/3987)) by @michaelpj+- Fix most -Wall in ghcide+  ([#3984](https://github.com/haskell/haskell-language-server/pull/3984)) by @jhrcek+- Fix -Wall and -Wunused-packages in pragmas plugin+  ([#3982](https://github.com/haskell/haskell-language-server/pull/3982)) by @jhrcek+- Fix -Wall and -Wunused-packages in eval plugin+  ([#3981](https://github.com/haskell/haskell-language-server/pull/3981)) by @jhrcek+- Fix -Wall and -Wunused-packages in code-range plugin+  ([#3980](https://github.com/haskell/haskell-language-server/pull/3980)) by @jhrcek+- Fix -Wall, -Wunused-packages and hlint warnings in call-hierarchy plugin+  ([#3979](https://github.com/haskell/haskell-language-server/pull/3979)) by @jhrcek+- Fix -Wunused-packages in hls-cabal-plugin+  ([#3977](https://github.com/haskell/haskell-language-server/pull/3977)) by @jhrcek+- Merge plugins into the HLS package+  ([#3976](https://github.com/haskell/haskell-language-server/pull/3976)) by @michaelpj+- Fix most hlint warnings in ghcide+  ([#3975](https://github.com/haskell/haskell-language-server/pull/3975)) by @jhrcek+- Remove allow-newer for ghc-trace-events+  ([#3974](https://github.com/haskell/haskell-language-server/pull/3974)) by @jhrcek+- Exactprint plugins for 9.8+  ([#3973](https://github.com/haskell/haskell-language-server/pull/3973)) by @wz1000+- Fix -Wall and -Wunused-packages in hls-class-plugin+  ([#3972](https://github.com/haskell/haskell-language-server/pull/3972)) by @jhrcek+- Document cabal diagnostic options+  ([#3971](https://github.com/haskell/haskell-language-server/pull/3971)) by @fendor+- Fix -Wall and -Wunused-packages in change-type-signature plugin+  ([#3970](https://github.com/haskell/haskell-language-server/pull/3970)) by @jhrcek+- Semantic tokens: expand type synonym to checkout forall function type when possible+  ([#3967](https://github.com/haskell/haskell-language-server/pull/3967)) by @soulomoon+- Fix -Wunused-packages in hls-cabal-fmt-plugin+  ([#3965](https://github.com/haskell/haskell-language-server/pull/3965)) by @jhrcek+- Fix -Wall and -Wunused-packages in hls-alternate-number-format-plugin+  ([#3964](https://github.com/haskell/haskell-language-server/pull/3964)) by @jhrcek+- Prepare release 2.6.0.0+  ([#3959](https://github.com/haskell/haskell-language-server/pull/3959)) by @wz1000+- Semantic tokens: add module name support and improve performance and accuracy by traversing the hieAst along with source code+  ([#3958](https://github.com/haskell/haskell-language-server/pull/3958)) by @soulomoon+- Bump cachix/cachix-action from 13 to 14+  ([#3956](https://github.com/haskell/haskell-language-server/pull/3956)) by @dependabot[bot]+- Bump cachix/install-nix-action from 24 to 25+  ([#3955](https://github.com/haskell/haskell-language-server/pull/3955)) by @dependabot[bot]+- Remove unused dependencies in hls-refactor-plugin+  ([#3953](https://github.com/haskell/haskell-language-server/pull/3953)) by @jhrcek+- Cleanup conditional build logic pertaining to pre 9.2 GHCs+  ([#3948](https://github.com/haskell/haskell-language-server/pull/3948)) by @jhrcek+- Fix issue:  HLS HLint plugin doesn't preserve HLint's severities #3881+  ([#3902](https://github.com/haskell/haskell-language-server/pull/3902)) by @IAmPara0x+- Don't run hlint on testdata directories+  ([#3901](https://github.com/haskell/haskell-language-server/pull/3901)) by @fendor+-  Add option for setting manual path to Fourmolu binary+  ([#3860](https://github.com/haskell/haskell-language-server/pull/3860)) by @georgefst+ ## 2.6.0.0  - Bindists for GHC 9.6.4 - A new semantic tokens plugin (#3892, @soulomoon).-- Improvements to multiple home unit support with GHC 9.4. Using cabal 3.11+ will+- Improvements to multiple home unit support with GHC 9.4. When HLS is used with cabal 3.11+ it will   load proper multiple home unit sessions by default, fixing a lot of issues with   loading and reloading projects that have more than one component (#3462, @wz1000). - Removed implicit-hie, resulting in better behaviour for projects without cradles.@@ -15,7 +192,7 @@  - fix: semantic token omitting record field in `{-# LANGUAGE DuplicateRecordFields  #-}` #3950   ([#3951](https://github.com/haskell/haskell-language-server/pull/3951)) by @soulomoon-- Properties API: Remove unsafe coerce in favor of type class based method in +- Properties API: Remove unsafe coerce in favor of type class based method in   ([#3947](https://github.com/haskell/haskell-language-server/pull/3947)) by @soulomoon - Bump to hiedb 0.5.0.0 to fix #3542   ([#3943](https://github.com/haskell/haskell-language-server/pull/3943)) by @wz1000@@ -51,7 +228,7 @@   ([#3913](https://github.com/haskell/haskell-language-server/pull/3913)) by @michaelpj - Update ghc-version-support.md for 2.5.0   ([#3909](https://github.com/haskell/haskell-language-server/pull/3909)) by @lehmacdj-- Give plugins descriptions, include versions of key dependencies +- Give plugins descriptions, include versions of key dependencies   ([#3903](https://github.com/haskell/haskell-language-server/pull/3903)) by @michaelpj - Remove some buildability blockers that aren't needed   ([#3899](https://github.com/haskell/haskell-language-server/pull/3899)) by @michaelpj
exe/Main.hs view
@@ -1,9 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-} module Main(main) where  import           Control.Exception             (displayException)
exe/Wrapper.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE ExplicitNamespaces         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where
haskell-language-server.cabal view
@@ -1,640 +1,1865 @@-cabal-version:      3.0-category:           Development-name:               haskell-language-server-version:            2.6.0.0-synopsis:           LSP server for GHC-description:-  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>--homepage:           https://github.com/haskell/haskell-language-server#readme-bug-reports:        https://github.com/haskell/haskell-language-server/issues-author:             The Haskell IDE Team-maintainer:         alan.zimm@gmail.com-copyright:          The Haskell IDE Team-license:            Apache-2.0-license-file:       LICENSE-build-type:         Simple-tested-with:        GHC == 9.0.2 || ==9.2.5-extra-source-files:-  README.md-  ChangeLog.md-  test/testdata/**/*.project-  test/testdata/**/*.cabal-  test/testdata/**/*.yaml-  test/testdata/**/*.hs-  bindist/wrapper.in--flag pedantic-  description: Enable -Werror-  default:     False-  manual:      True--source-repository head-  type:     git-  location: https://github.com/haskell/haskell-language-server--common common-deps-  build-depends:-    , base       >=4.12 && <5-    , directory-    , extra-    , filepath-    , text-    , prettyprinter >= 1.7---- Default warnings in HLS-common warnings-  ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors---- Allow compiling in pedantic mode-common pedantic-  if flag(pedantic)-    ghc-options: -Werror---- Plugin flags are designed for 'cabal install haskell-language-server':--- - Bulk flags should be default:False--- - Individual flags should be default:True---- The intent of this flag is being able to keep the ghc condition for hackage--- but skip it via flags in cabal.project as plugins for new ghcs usually--- are buildable using cabal.project tweaks-flag ignore-plugins-ghc-bounds-  description: Force the inclusion of plugins even if they are not buildable by default with a specific ghc version-  default:     False-  manual:      True---flag cabal-  description: Enable cabal plugin-  default:     True-  manual:      True--flag class-  description: Enable class plugin-  default:     True-  manual:      True--flag callHierarchy-  description: Enable call hierarchy plugin-  default:     True-  manual:      True--flag eval-  description: Enable eval plugin-  default:     True-  manual:      True--flag importLens-  description: Enable importLens plugin-  default:     True-  manual:      True--flag rename-  description: Enable rename plugin-  default:     True-  manual:      True--flag retrie-  description: Enable retrie plugin-  default:     True-  manual:      True--flag hlint-  description: Enable hlint plugin-  default:     True-  manual:      True--flag stan-  description: Enable stan plugin-  default:     True-  manual:      True--flag moduleName-  description: Enable moduleName plugin-  default:     True-  manual:      True--flag pragmas-  description: Enable pragmas plugin-  default:     True-  manual:      True--flag splice-  description: Enable splice plugin-  default:     True-  manual:      True--flag alternateNumberFormat-  description: Enable Alternate Number Format plugin-  default:     True-  manual:      True--flag qualifyImportedNames-  description: Enable qualifyImportedNames plugin-  default:     True-  manual:      True--flag codeRange-  description: Enable Code Range plugin-  default:     True-  manual:      True--flag changeTypeSignature-  description: Enable changeTypeSignature plugin-  default:     True-  manual:      True--flag gadt-  description: Enable gadt plugin-  default:     True-  manual:      True--flag explicitFixity-  description: Enable explicitFixity plugin-  default:     True-  manual:      True--flag explicitFields-  description: Enable explicitFields plugin-  default:     True-  manual:      True--flag overloadedRecordDot-  description: Enable overloadedRecordDot plugin-  default:     True-  manual:      True--flag semanticTokens-  description: Enable semantic tokens plugin-  default:     True-  manual:      True---- formatters--flag floskell-  description: Enable floskell plugin-  default:     True-  manual:      True--flag fourmolu-  description: Enable fourmolu plugin-  default:     True-  manual:      True--flag ormolu-  description: Enable ormolu plugin-  default:     True-  manual:      True--flag stylishHaskell-  description: Enable stylishHaskell plugin-  default:     True-  manual:      True--flag refactor-  description: Enable refactor plugin-  default:     True-  manual:      True--flag dynamic-  description: Build with the dyn rts-  default:     True-  manual:      True--flag cabalfmt-  description: Enable cabal-fmt plugin-  default:     True-  manual:      True--common cabalfmt-  if flag(cabalfmt)-    build-depends: hls-cabal-fmt-plugin == 2.6.0.0-    cpp-options: -Dhls_cabalfmt--common cabal-  if flag(cabal)-    build-depends: hls-cabal-plugin == 2.6.0.0-    cpp-options: -Dhls_cabal--common class-  if flag(class) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-class-plugin == 2.6.0.0-    cpp-options: -Dhls_class--common callHierarchy-  if flag(callHierarchy)-    build-depends: hls-call-hierarchy-plugin == 2.6.0.0-    cpp-options: -Dhls_callHierarchy--common eval-  if flag(eval)-    build-depends: hls-eval-plugin == 2.6.0.0-    cpp-options: -Dhls_eval--common importLens-  if flag(importLens)-    build-depends: hls-explicit-imports-plugin == 2.6.0.0-    cpp-options: -Dhls_importLens--common rename-  if flag(rename) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-rename-plugin == 2.6.0.0-    cpp-options: -Dhls_rename--common retrie-  if flag(retrie) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-retrie-plugin == 2.6.0.0-    cpp-options: -Dhls_retrie--common hlint-  if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-hlint-plugin == 2.6.0.0-    cpp-options: -Dhls_hlint--common stan-  if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0))-    build-depends: hls-stan-plugin == 2.6.0.0-    cpp-options: -Dhls_stan--common moduleName-  if flag(moduleName)-    build-depends: hls-module-name-plugin == 2.6.0.0-    cpp-options: -Dhls_moduleName--common pragmas-  if flag(pragmas)-    build-depends: hls-pragmas-plugin == 2.6.0.0-    cpp-options: -Dhls_pragmas--common splice-  if flag(splice) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-splice-plugin == 2.6.0.0-    cpp-options: -Dhls_splice--common alternateNumberFormat-  if flag(alternateNumberFormat)-    build-depends: hls-alternate-number-format-plugin == 2.6.0.0-    cpp-options: -Dhls_alternateNumberFormat--common qualifyImportedNames-  if flag(qualifyImportedNames)-    build-depends: hls-qualify-imported-names-plugin == 2.6.0.0-    cpp-options: -Dhls_qualifyImportedNames--common codeRange-  if flag(codeRange)-    build-depends: hls-code-range-plugin == 2.6.0.0-    cpp-options: -Dhls_codeRange--common changeTypeSignature-  if flag(changeTypeSignature)-    build-depends: hls-change-type-signature-plugin == 2.6.0.0-    cpp-options: -Dhls_changeTypeSignature--common gadt-  if flag(gadt) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-gadt-plugin == 2.6.0.0-    cpp-options: -Dhls_gadt--common explicitFixity-  if flag(explicitFixity)-    build-depends: hls-explicit-fixity-plugin == 2.6.0.0-    cpp-options: -DexplicitFixity--common explicitFields-  if flag(explicitFields)-    build-depends: hls-explicit-record-fields-plugin == 2.6.0.0-    cpp-options: -DexplicitFields--common overloadedRecordDot-  if flag(overloadedRecordDot) && (impl(ghc >= 9.2.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-overloaded-record-dot-plugin == 2.6.0.0-    cpp-options: -Dhls_overloaded_record_dot---- formatters--common floskell-  if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-floskell-plugin == 2.6.0.0-    cpp-options: -Dhls_floskell--common fourmolu-  if flag(fourmolu)-    build-depends: hls-fourmolu-plugin == 2.6.0.0-    cpp-options: -Dhls_fourmolu--common ormolu-  if flag(ormolu)-    build-depends: hls-ormolu-plugin == 2.6.0.0-    cpp-options: -Dhls_ormolu--common stylishHaskell-  if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-stylish-haskell-plugin == 2.6.0.0-    cpp-options: -Dhls_stylishHaskell--common refactor-  if flag(refactor) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))-    build-depends: hls-refactor-plugin == 2.6.0.0-    cpp-options: -Dhls_refactor--common semanticTokens-  if flag(semanticTokens)-    build-depends: hls-semantic-tokens-plugin == 2.6.0.0-    cpp-options: -Dhls_semanticTokens---library-  import:           common-deps-                    -- configuration-                  , warnings-                  , pedantic-                  -- plugins-                  , cabal-                  , callHierarchy-                  , cabalfmt-                  , changeTypeSignature-                  , class-                  , eval-                  , importLens-                  , rename-                  , retrie-                  , hlint-                  , stan-                  , moduleName-                  , pragmas-                  , splice-                  , alternateNumberFormat-                  , qualifyImportedNames-                  , codeRange-                  , gadt-                  , explicitFixity-                  , explicitFields-                  , floskell-                  , fourmolu-                  , ormolu-                  , stylishHaskell-                  , refactor-                  , overloadedRecordDot-                  , semanticTokens--  exposed-modules:-    Ide.Arguments-    Ide.Main-    Ide.Version-    HlsPlugins--  other-modules:    Paths_haskell_language_server-  autogen-modules:  Paths_haskell_language_server-  hs-source-dirs:   src-  build-depends:-    , async-    , base16-bytestring-    , bytestring-    , containers-    , cryptohash-sha1-    , data-default-    , ghc-    , ghcide                == 2.6.0.0-    , githash               >=0.1.6.1-    , lsp                   >= 2.3.0.0-    , hie-bios-    , hiedb-    , hls-plugin-api        == 2.6.0.0-    , optparse-applicative-    , optparse-simple-    , process-    , hls-graph-    , safe-exceptions-    , sqlite-simple-    , unordered-containers-    , aeson-pretty--  default-language: Haskell2010-  default-extensions: DataKinds, TypeOperators--executable haskell-language-server-  import:           common-deps-                    -- configuration-                  , warnings-                  , pedantic-  main-is:          Main.hs-  hs-source-dirs:   exe--  ghc-options:-    -threaded-    -- allow user RTS overrides-    -rtsopts-    -- disable idle GC-    -- increase nursery size-    -- Enable collection of heap statistics-    "-with-rtsopts=-I0 -A128M -T"-    -Wno-unticked-promoted-constructors-  if flag(pedantic)-    ghc-options: -Werror-  if !os(windows) && flag(dynamic)-  -- We want to link against the dyn rts just like official GHC binaries do;-  --   the linked rts determines how external libs are loaded dynamically by TH.-  -- The standard way of doing this is via the --enable-dynamic-executables Cabal option-  -- Unfortunately it doesnt' work, see https://github.com/haskell/haskell-language-server/issues/2659-  -- One can use --ghc-options=-dynamic but this gets applied to the dependencies as well,-  -- which results in massive rebuilds and incompatibilities with profiling.-  -- So instead we set the -dynamic flag diretly here.-    ghc-options: -dynamic--  build-depends:-    , aeson-    , async-    , base16-bytestring-    , binary-    , bytestring-    , containers-    , cryptohash-sha1-    , deepseq-    , ghc-    , ghc-boot-th-    , ghcide-    , hashable-    , haskell-language-server-    , lsp-    , hie-bios-    , hiedb-    , lens-    , regex-tdfa-    , optparse-applicative-    , hls-plugin-api-    , lens-    , mtl-    , regex-tdfa-    , safe-exceptions-    , hls-graph-    , sqlite-simple-    , stm-    , temporary-    , transformers-    , unordered-containers--  default-language: Haskell2010-  default-extensions: DataKinds, TypeOperators--executable haskell-language-server-wrapper-  import:           common-deps-                  , warnings-                  , pedantic-  main-is:          Wrapper.hs-  hs-source-dirs:   exe-  other-modules:    Paths_haskell_language_server-  autogen-modules:  Paths_haskell_language_server-  ghc-options:-    -threaded-    -- allow user RTS overrides-    -rtsopts-    -- disable idle GC-    -- increase nursery size-    "-with-rtsopts=-I0 -A128M"--  build-depends:-    , data-default-    , ghc-    , ghc-paths-    , ghcide-    , gitrev-    , haskell-language-server-    , hie-bios-    , hls-plugin-api-    , lsp-    , lsp-types-    , mtl-    , optparse-applicative-    , optparse-simple-    , process-    , transformers-    , unliftio-core-  if !os(windows)-      build-depends:-          unix-        , containers--  default-language: Haskell2010---test-suite func-test-  import:             common-deps-                    , warnings-                    , pedantic-                    , refactor-  type:               exitcode-stdio-1.0-  default-language:   Haskell2010-  build-tool-depends:-    haskell-language-server:haskell-language-server -any,-    ghcide:ghcide-test-preprocessor -any--  build-depends:-    , bytestring-    , data-default-    , deepseq-    , hashable-    , lens-    , lens-aeson-    , ghcide-    , ghcide-test-utils-    , hls-test-utils == 2.6.0.0-    , lsp-types-    , aeson-    , hls-plugin-api-    , lsp-test-    , containers-    , unordered-containers-    , row-types--  hs-source-dirs:     test/functional test/utils--  main-is:            Main.hs-  other-modules:-    Config-    ConfigSchema-    Format-    FunctionalBadProject-    HieBios-    Progress-    Test.Hls.Command-    Test.Hls.Flags--  default-extensions: OverloadedStrings-  ghc-options:-    -threaded -rtsopts -with-rtsopts=-N---- Duplicating inclusion plugin conditions until tests are moved to their own packages-  if flag(eval)-    cpp-options: -Dhls_eval--- formatters-  if flag(floskell)-    cpp-options: -Dhls_floskell-  if flag(fourmolu)-    cpp-options: -Dhls_fourmolu-  if flag(ormolu)-    cpp-options: -Dhls_ormolu--test-suite wrapper-test-  import:             common-deps-                    , warnings-                    , pedantic-  type:               exitcode-stdio-1.0-  build-tool-depends:-    haskell-language-server:haskell-language-server-wrapper -any,-    haskell-language-server:haskell-language-server -any--  default-language:   Haskell2010-  build-depends:-      process-    , hls-test-utils--  hs-source-dirs:     test/wrapper-  main-is:            Main.hs--benchmark benchmark-    -- Depends on shake-bench which is unbuildable after this point-    if impl(ghc >= 9.5)-      buildable: False-    type: exitcode-stdio-1.0-    default-language: Haskell2010-    ghc-options: -Wall -Wno-name-shadowing -threaded-    main-is: Main.hs-    hs-source-dirs: bench-    build-tool-depends:-        ghcide-bench:ghcide-bench,-        hp2pretty:hp2pretty,-        implicit-hie:gen-hie-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns--    build-depends:-        aeson,-        base == 4.*,-        containers,-        data-default,-        directory,-        extra,-        filepath,-        ghcide-bench,-        haskell-language-server,-        hls-plugin-api,-        lens,-        lens-aeson,-        optparse-applicative,-        shake,-        shake-bench == 0.2.*,-        text,-        yaml+cabal-version:      3.4+category:           Development+name:               haskell-language-server+version:            2.7.0.0+synopsis:           LSP server for GHC+description:+  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>++homepage:           https://github.com/haskell/haskell-language-server#readme+bug-reports:        https://github.com/haskell/haskell-language-server/issues+author:             The Haskell IDE Team+maintainer:         alan.zimm@gmail.com+copyright:          The Haskell IDE Team+license:            Apache-2.0+license-file:       LICENSE+build-type:         Simple+tested-with:        GHC == 9.8.2 || ==9.6.4 || ==9.4.8 || ==9.2.8+extra-source-files:+  README.md+  ChangeLog.md+  test/testdata/**/*.project+  test/testdata/**/*.cabal+  test/testdata/**/*.yaml+  test/testdata/**/*.hs+  test/testdata/**/*.json++  -- These globs should only match test/testdata+  plugins/**/*.project+  plugins/**/*.expected+  plugins/**/*.cabal+  plugins/**/*.yaml+  plugins/**/*.txt+  plugins/**/*.hs++  bindist/wrapper.in++source-repository head+  type:     git+  location: https://github.com/haskell/haskell-language-server++common defaults+  default-language: GHC2021+  -- Should have been in GHC2021, an oversight+  default-extensions: ExplicitNamespaces++common test-defaults+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N++-- Default warnings in HLS+common warnings+  ghc-options: -Wall+               -Wredundant-constraints+               -Wunused-packages+               -Wno-name-shadowing+               -Wno-unticked-promoted-constructors++flag pedantic+  description: Enable -Werror+  default:     False+  manual:      True++-- Allow compiling in pedantic mode+common pedantic+  if flag(pedantic)+    ghc-options:+      -Werror+      -- Note [unused-packages] Some packages need CPP conditioned on MIN_VERSION_ghc(x,y,z).+      -- MIN_VERSION_<pkg> is CPP macro that cabal defines only when <pkg> is declared as a dependency.+      -- But -Wunused-packages still reports it as unused dependency if it's not imported.+      -- For packages with such "unused" dependencies we demote -Wunused-packages error+      -- (enabled by --flag=pedantic) to warning via -Wwarn=unused-packages.+      -Wwarn=unused-packages++-- Plugin flags are designed for 'cabal install haskell-language-server':+-- - Bulk flags should be default:False+-- - Individual flags should be default:True++-- The intent of this flag is being able to keep the ghc condition for hackage+-- but skip it via flags in cabal.project as plugins for new ghcs usually+-- are buildable using cabal.project tweaks+flag ignore-plugins-ghc-bounds+  description: Force the inclusion of plugins even if they are not buildable by default with a specific ghc version+  default:     False+  manual:      True++flag dynamic+  description: Build with the dyn rts+  default:     True+  manual:      True++----------------------------+----------------------------+-- PLUGINS+----------------------------+----------------------------++-----------------------------+-- cabal-fmt plugin+-----------------------------++flag cabalfmt+  description: Enable cabal-fmt plugin+  default:     True+  manual:      True++common cabalfmt+  if flag(cabalfmt)+    build-depends: haskell-language-server:hls-cabal-fmt-plugin+    cpp-options: -Dhls_cabalfmt++flag isolateCabalfmtTests+  description: Should tests search for 'cabal-fmt' on the $PATH or shall we install it via build-tool-depends?+  -- By default, search on the PATH+  default:     False+  manual:      True++library hls-cabal-fmt-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.CabalFmt+  hs-source-dirs:   plugins/hls-cabal-fmt-plugin/src+  build-depends:+    , base            >=4.12 && <5+    , directory+    , filepath+    , ghcide          == 2.7.0.0+    , hls-plugin-api  == 2.7.0.0+    , lens+    , lsp-types+    , mtl+    , process-extras+    , text++test-suite hls-cabal-fmt-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-cabal-fmt-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , directory+    , filepath+    , haskell-language-server:hls-cabal-fmt-plugin+    , hls-test-utils        == 2.7.0.0++  if flag(isolateCabalfmtTests)+    build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6++-----------------------------+-- cabal plugin+-----------------------------++flag cabal+  description: Enable cabal plugin+  default:     True+  manual:      True++common cabal+  if flag(cabal)+    build-depends: haskell-language-server:hls-cabal-plugin+    cpp-options: -Dhls_cabal++library hls-cabal-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:+    Ide.Plugin.Cabal+    Ide.Plugin.Cabal.Diagnostics+    Ide.Plugin.Cabal.Completion.Completer.FilePath+    Ide.Plugin.Cabal.Completion.Completer.Module+    Ide.Plugin.Cabal.Completion.Completer.Paths+    Ide.Plugin.Cabal.Completion.Completer.Simple+    Ide.Plugin.Cabal.Completion.Completer.Snippet+    Ide.Plugin.Cabal.Completion.Completer.Types+    Ide.Plugin.Cabal.Completion.Completions+    Ide.Plugin.Cabal.Completion.Data+    Ide.Plugin.Cabal.Completion.Types+    Ide.Plugin.Cabal.LicenseSuggest+    Ide.Plugin.Cabal.Parse+++  build-depends:+    , base                  >=4.12     && <5+    , bytestring+    , Cabal-syntax          >= 3.7+    , containers+    , deepseq+    , directory+    , filepath+    , extra                 >=1.7.4+    , ghcide                == 2.7.0.0+    , hashable+    , hls-plugin-api        == 2.7.0.0+    , hls-graph             == 2.7.0.0+    , lens+    , lsp                   ^>=2.4+    , lsp-types             ^>=2.1+    , regex-tdfa            ^>=1.3.1+    , stm+    , text+    , text-rope+    , transformers+    , unordered-containers  >=0.2.10.0+    , containers+  hs-source-dirs:   plugins/hls-cabal-plugin/src++test-suite hls-cabal-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-cabal-plugin/test+  main-is:          Main.hs+  other-modules:+    Completer+    Context+    Utils+  build-depends:+    , base+    , bytestring+    , Cabal-syntax          >= 3.7+    , filepath+    , ghcide+    , haskell-language-server:hls-cabal-plugin+    , hls-test-utils    == 2.7.0.0+    , lens+    , lsp-types+    , text+    , text-rope+    , transformers+    , row-types++-----------------------------+-- class plugin+-----------------------------++flag class+  description: Enable class plugin+  default:     True+  manual:      True++common class+  if flag(class)+    build-depends: haskell-language-server:hls-class-plugin+    cpp-options: -Dhls_class++library hls-class-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:    Ide.Plugin.Class+  other-modules:      Ide.Plugin.Class.CodeAction+                    , Ide.Plugin.Class.CodeLens+                    , Ide.Plugin.Class.ExactPrint+                    , Ide.Plugin.Class.Types+                    , Ide.Plugin.Class.Utils+  hs-source-dirs:     plugins/hls-class-plugin/src+  build-depends:+    , aeson+    , base            >=4.12 && <5+    , containers+    , deepseq+    , extra+    , ghc+    , ghc-exactprint  >= 1.5+    , ghcide          == 2.7.0.0+    , hls-graph+    , hls-plugin-api  == 2.7.0.0+    , lens+    , lsp+    , mtl+    , text+    , transformers++  default-extensions:+    DataKinds+    OverloadedStrings++test-suite hls-class-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-class-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-class-plugin+    , hls-test-utils     == 2.7.0.0+    , lens+    , lsp-types+    , row-types+    , text++-----------------------------+-- call-hierarchy plugin+-----------------------------++flag callHierarchy+  description: Enable call hierarchy plugin+  default:     True+  manual:      True++common callHierarchy+  if flag(callHierarchy)+    build-depends: haskell-language-server:hls-call-hierarchy-plugin+    cpp-options: -Dhls_callHierarchy++library hls-call-hierarchy-plugin+  import: defaults, pedantic, warnings+  buildable: True+  exposed-modules:    Ide.Plugin.CallHierarchy+  other-modules:+    Ide.Plugin.CallHierarchy.Internal+    Ide.Plugin.CallHierarchy.Query+    Ide.Plugin.CallHierarchy.Types++  hs-source-dirs:     plugins/hls-call-hierarchy-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12 && <5+    , containers+    , extra+    , ghcide                == 2.7.0.0+    , hiedb                 ^>= 0.6.0.0+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp                    >=2.4+    , sqlite-simple+    , text++  default-extensions: DataKinds++test-suite hls-call-hierarchy-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-call-hierarchy-plugin/test+  main-is:          Main.hs+  build-depends:+    , aeson+    , base+    , containers+    , extra+    , filepath+    , haskell-language-server:hls-call-hierarchy-plugin+    , hls-test-utils        == 2.7.0.0+    , ghcide:ghcide-test-utils+    , lens+    , lsp+    , lsp-test+    , text++-----------------------------+-- eval plugin+-----------------------------++flag eval+  description: Enable eval plugin+  default:     True+  manual:      True++common eval+  if flag(eval)+    build-depends: haskell-language-server:hls-eval-plugin+    cpp-options: -Dhls_eval++library hls-eval-plugin+  import: defaults, pedantic, warnings+  exposed-modules:+    Ide.Plugin.Eval+    Ide.Plugin.Eval.Types++  hs-source-dirs:     plugins/hls-eval-plugin/src+  other-modules:+    Ide.Plugin.Eval.Code+    Ide.Plugin.Eval.CodeLens+    Ide.Plugin.Eval.Config+    Ide.Plugin.Eval.GHC+    Ide.Plugin.Eval.Parse.Comments+    Ide.Plugin.Eval.Parse.Option+    Ide.Plugin.Eval.Rules+    Ide.Plugin.Eval.Util++  build-depends:+    , aeson+    , base                  >=4.12  && <5+    , bytestring+    , containers+    , deepseq+    , Diff                  ^>=0.4.0+    , dlist+    , extra+    , filepath+    , ghc+    , ghc-boot-th+    , ghcide                == 2.7.0.0+    , hls-graph+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp+    , lsp-types+    , megaparsec            >=9.0+    , mtl+    , parser-combinators    >=1.2+    , text+    , transformers+    , unliftio+    , unordered-containers++  default-extensions:+    DataKinds++test-suite hls-eval-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-eval-plugin/test+  main-is:          Main.hs+  ghc-options:      -fno-ignore-asserts+  build-depends:+    , aeson+    , base+    , containers+    , extra+    , filepath+    , haskell-language-server:hls-eval-plugin+    , hls-plugin-api+    , hls-test-utils   == 2.7.0.0+    , lens+    , lsp-types+    , text+    , row-types++-----------------------------+-- import lens plugin+-----------------------------++common importLens+  if flag(importLens)+    build-depends: haskell-language-server:hls-explicit-imports-plugin+    cpp-options: -Dhls_importLens++flag importLens+  description: Enable importLens plugin+  default:     True+  manual:      True++library hls-explicit-imports-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.ExplicitImports+  hs-source-dirs:   plugins/hls-explicit-imports-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12 && <5+    , containers+    , deepseq+    , ghc+    , ghcide                == 2.7.0.0+    , hls-graph+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp+    , mtl+    , text+    , transformers++  default-extensions:+    DataKinds++test-suite hls-explicit-imports-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-explicit-imports-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , extra+    , filepath+    , haskell-language-server:hls-explicit-imports-plugin+    , hls-test-utils   == 2.7.0.0+    , lens+    , lsp-types+    , row-types+    , text++-----------------------------+-- rename plugin+-----------------------------++flag rename+  description: Enable rename plugin+  default:     True+  manual:      True++common rename+  if flag(rename)+    build-depends: haskell-language-server:hls-rename-plugin+    cpp-options: -Dhls_rename++library hls-rename-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Rename+  hs-source-dirs:   plugins/hls-rename-plugin/src+  build-depends:+    , base                  >=4.12    && <5+    , containers+    , ghcide                == 2.7.0.0+    , hashable+    , hiedb                 ^>= 0.6.0.0+    , hie-compat+    , hls-plugin-api        == 2.7.0.0+    , haskell-language-server:hls-refactor-plugin+    , lens+    , lsp+    , lsp-types+    , mtl+    , mod+    , syb+    , text+    , transformers+    , unordered-containers+++test-suite hls-rename-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-rename-plugin/test+  main-is:          Main.hs+  build-depends:+    , aeson+    , base+    , containers+    , filepath+    , hls-plugin-api+    , haskell-language-server:hls-rename-plugin+    , hls-test-utils             == 2.7.0.0++-----------------------------+-- retrie plugin+-----------------------------++flag retrie+  description: Enable retrie plugin+  default:     True+  manual:      True++common retrie+  if flag(retrie)+    build-depends: haskell-language-server:hls-retrie-plugin+    cpp-options: -Dhls_retrie++library hls-retrie-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Retrie+  hs-source-dirs:   plugins/hls-retrie-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12    && <5+    , bytestring+    , containers+    , directory+    , extra+    , ghc+    , ghcide                == 2.7.0.0+    , hashable+    , hls-plugin-api        == 2.7.0.0+    , haskell-language-server:hls-refactor-plugin+    , lens+    , lsp+    , lsp-types+    , mtl+    , retrie                >=0.1.1.0+    , safe-exceptions+    , stm+    , text+    , transformers+    , unordered-containers++  default-extensions:+    DataKinds++test-suite hls-retrie-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-retrie-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , containers+    , filepath+    , hls-plugin-api+    , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin}+    , hls-test-utils             == 2.7.0.0+    , text++-----------------------------+-- hlint plugin+-----------------------------++flag hlint+  description: Enable hlint plugin+  default:     True+  manual:      True++common hlint+  if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))+    build-depends: haskell-language-server:hls-hlint-plugin+    cpp-options: -Dhls_hlint++library hls-hlint-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Hlint+  hs-source-dirs:   plugins/hls-hlint-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12    && <5+    , bytestring+    , containers+    , deepseq+    , filepath+    , ghcide                == 2.7.0.0+    , hashable+    , hlint                 >= 3.5 && < 3.9+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp+    , mtl+    , refact+    , regex-tdfa+    , stm+    , temporary+    , text+    , transformers+    , unordered-containers+    , ghc-lib-parser+    , ghc-lib-parser-ex+    , apply-refact++  cpp-options:   -DHLINT_ON_GHC_LIB++  default-extensions:+    DataKinds++test-suite hls-hlint-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-hlint-plugin/test+  main-is:          Main.hs+  build-depends:+      aeson+    , base+    , containers+    , filepath+    , haskell-language-server:hls-hlint-plugin+    , hls-plugin-api+    , hls-test-utils      == 2.7.0.0+    , lens+    , lsp-types+    , row-types+    , text++-----------------------------+-- stan plugin+-----------------------------++flag stan+  description: Enable stan plugin+  default:     True+  manual:      True++common stan+  if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0))+    build-depends: haskell-language-server:hls-stan-plugin+    cpp-options: -Dhls_stan++library hls-stan-plugin+  import:           defaults, pedantic, warnings+  if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0))+    buildable: True+  else+    buildable: False+  exposed-modules:    Ide.Plugin.Stan+  hs-source-dirs:     plugins/hls-stan-plugin/src+  build-depends:+      base+    , deepseq+    , hashable+    , hie-compat+    , hls-plugin-api+    , ghcide+    , lsp-types+    , text+    , unordered-containers+    , stan >= 0.1.2.0+    , trial+    , directory++  default-extensions:+    LambdaCase+    TypeFamilies+    DuplicateRecordFields+    OverloadedStrings++test-suite hls-stan-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0))+    buildable: True+  else+    buildable: False+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-stan-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-stan-plugin+    , hls-plugin-api+    , hls-test-utils      == 2.7.0.0+    , lens+    , lsp-types+    , text+ default-extensions:+    OverloadedStrings++-----------------------------+-- module name plugin+-----------------------------++flag moduleName+  description: Enable moduleName plugin+  default:     True+  manual:      True++common moduleName+  if flag(moduleName)+    build-depends: haskell-language-server:hls-module-name-plugin+    cpp-options: -Dhls_moduleName++library hls-module-name-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.ModuleName+  hs-source-dirs:   plugins/hls-module-name-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12 && <5+    , containers+    , directory+    , filepath+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lsp+    , text+    , transformers+++test-suite hls-module-name-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-module-name-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-module-name-plugin+    , hls-test-utils          == 2.7.0.0++-----------------------------+-- pragmas plugin+-----------------------------++flag pragmas+  description: Enable pragmas plugin+  default:     True+  manual:      True++common pragmas+  if flag(pragmas)+    build-depends: haskell-language-server:hls-pragmas-plugin+    cpp-options: -Dhls_pragmas++library hls-pragmas-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Pragmas+  hs-source-dirs:   plugins/hls-pragmas-plugin/src+  build-depends:+    , base                  >=4.12 && <5+    , extra+    , fuzzy+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp+    , text+    , transformers+    , containers++test-suite hls-pragmas-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-pragmas-plugin/test+  main-is:          Main.hs+  build-depends:+    , aeson+    , base+    , filepath+    , haskell-language-server:hls-pragmas-plugin+    , hls-test-utils      == 2.7.0.0+    , lens+    , lsp-types+    , text++-----------------------------+-- splice plugin+-----------------------------++flag splice+  description: Enable splice plugin+  default:     True+  manual:      True++common splice+  if flag(splice)+    build-depends: haskell-language-server:hls-splice-plugin+    cpp-options: -Dhls_splice++library hls-splice-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:+    Ide.Plugin.Splice+    Ide.Plugin.Splice.Types++  hs-source-dirs:     plugins/hls-splice-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12 && <5+    , extra+    , foldl+    , ghc+    , ghc-exactprint+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , haskell-language-server:hls-refactor-plugin+    , lens+    , lsp+    , mtl+    , syb+    , text+    , transformers+    , unliftio-core++  default-extensions:+    DataKinds++test-suite hls-splice-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-splice-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-splice-plugin+    , hls-test-utils == 2.7.0.0+    , text+    , row-types++-----------------------------+-- alternate number format plugin+-----------------------------++flag alternateNumberFormat+  description: Enable Alternate Number Format plugin+  default:     True+  manual:      True++common alternateNumberFormat+  if flag(alternateNumberFormat)+    build-depends: haskell-language-server:hls-alternate-number-format-plugin+    cpp-options: -Dhls_alternateNumberFormat++library hls-alternate-number-format-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion+  other-modules:    Ide.Plugin.Literals+  hs-source-dirs:   plugins/hls-alternate-number-format-plugin/src+  build-depends:+    , base                 >=4.12 && < 5+    , containers+    , extra+    , ghcide               == 2.7.0.0+    , ghc-boot-th+    , hls-graph+    , hls-plugin-api       == 2.7.0.0+    , lens+    , lsp                  ^>=2.4+    , mtl+    , regex-tdfa+    , syb+    , text++  default-extensions:+    LambdaCase+    OverloadedStrings+    RecordWildCards++test-suite hls-alternate-number-format-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-alternate-number-format-plugin/test+  other-modules:    Properties.Conversion+  main-is:          Main.hs+  ghc-options:      -fno-ignore-asserts+  build-depends:+    , base                 >=4.12 && < 5+    , filepath+    , haskell-language-server:hls-alternate-number-format-plugin+    , hls-test-utils       == 2.7.0.0+    , regex-tdfa+    , tasty-quickcheck+    , text++  default-extensions:+    LambdaCase+    OverloadedStrings+    RecordWildCards++-----------------------------+-- qualify imported names plugin+-----------------------------++flag qualifyImportedNames+  description: Enable qualifyImportedNames plugin+  default:     True+  manual:      True++common qualifyImportedNames+  if flag(qualifyImportedNames)+    build-depends: haskell-language-server:hls-qualify-imported-names-plugin+    cpp-options: -Dhls_qualifyImportedNames++library hls-qualify-imported-names-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.QualifyImportedNames+  hs-source-dirs:   plugins/hls-qualify-imported-names-plugin/src+  build-depends:+    , base                  >=4.12 && <5+    , containers+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp+    , text+    , dlist+    , transformers++  default-extensions:+    DataKinds++test-suite hls-qualify-imported-names-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-qualify-imported-names-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , text+    , filepath+    , haskell-language-server:hls-qualify-imported-names-plugin+    , hls-test-utils             == 2.7.0.0++-----------------------------+-- code range plugin+-----------------------------++flag codeRange+  description: Enable Code Range plugin+  default:     True+  manual:      True++common codeRange+  if flag(codeRange)+    build-depends: haskell-language-server:hls-code-range-plugin+    cpp-options: -Dhls_codeRange++library hls-code-range-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:+    Ide.Plugin.CodeRange+    Ide.Plugin.CodeRange.Rules+  other-modules:+    Ide.Plugin.CodeRange.ASTPreProcess+  hs-source-dirs: plugins/hls-code-range-plugin/src+  build-depends:+    , base             >=4.12 && <5+    , containers+    , deepseq+    , extra+    , ghcide           == 2.7.0.0+    , hashable+    , hls-plugin-api   == 2.7.0.0+    , lens+    , lsp+    , mtl+    , semigroupoids+    , transformers+    , vector++test-suite hls-code-range-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-code-range-plugin/test+  main-is:          Main.hs+  other-modules:+    Ide.Plugin.CodeRangeTest+    Ide.Plugin.CodeRange.RulesTest+  build-depends:+    , base+    , bytestring+    , filepath+    , haskell-language-server:hls-code-range-plugin+    , hls-test-utils             == 2.7.0.0+    , lens+    , lsp+    , lsp-test+    , transformers+    , vector++-----------------------------+-- change type signature plugin+-----------------------------++flag changeTypeSignature+  description: Enable changeTypeSignature plugin+  default:     True+  manual:      True++common changeTypeSignature+  if flag(changeTypeSignature)+    build-depends: haskell-language-server:hls-change-type-signature-plugin+    cpp-options: -Dhls_changeTypeSignature++library hls-change-type-signature-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.ChangeTypeSignature+  hs-source-dirs:   plugins/hls-change-type-signature-plugin/src+  build-depends:+    , base             >=4.12 && < 5+    , ghcide           == 2.7.0.0+    , hls-plugin-api   == 2.7.0.0+    , lsp-types+    , regex-tdfa+    , syb+    , text+    , transformers+    , containers+  default-extensions:+    DataKinds+    ExplicitNamespaces+    OverloadedStrings+    RecordWildCards+++test-suite hls-change-type-signature-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-change-type-signature-plugin/test+  main-is:          Main.hs+  build-depends:+    , base                 >=4.12 && < 5+    , filepath+    , haskell-language-server:hls-change-type-signature-plugin+    , hls-test-utils       == 2.7.0.0+    , regex-tdfa+    , text+  default-extensions:+    OverloadedStrings+    ViewPatterns++-----------------------------+-- gadt plugin+-----------------------------++flag gadt+  description: Enable gadt plugin+  default:     True+  manual:      True++common gadt+  if flag(gadt)+    build-depends: haskell-language-server:hls-gadt-plugin+    cpp-options: -Dhls_gadt++library hls-gadt-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.GADT+  other-modules:    Ide.Plugin.GHC+  hs-source-dirs:   plugins/hls-gadt-plugin/src+  build-depends:+    , aeson+    , base                  >=4.12 && <5+    , containers+    , extra+    , ghc+    , ghcide                 == 2.7.0.0+    , ghc-exactprint+    , hls-plugin-api         == 2.7.0.0+    , haskell-language-server:hls-refactor-plugin+    , lens+    , lsp                    >=2.4+    , mtl+    , text+    , transformers++  default-extensions: DataKinds++test-suite hls-gadt-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-gadt-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-gadt-plugin+    , hls-test-utils              == 2.7.0.0+    , text++-----------------------------+-- explicit fixity plugin+-----------------------------++flag explicitFixity+  description: Enable explicitFixity plugin+  default:     True+  manual:      True++common explicitFixity+  if flag(explicitFixity)+    build-depends: haskell-language-server:hls-explicit-fixity-plugin+    cpp-options: -DexplicitFixity++library hls-explicit-fixity-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.ExplicitFixity+  hs-source-dirs:   plugins/hls-explicit-fixity-plugin/src+  build-depends:+      base                  >=4.12 && <5+    , containers+    , deepseq+    , extra+    , ghcide                == 2.7.0.0+    , hashable+    , hls-plugin-api        == 2.7.0.0+    , lsp                   >=2.4+    , text++  default-extensions: DataKinds++test-suite hls-explicit-fixity-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-explicit-fixity-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-explicit-fixity-plugin+    , hls-test-utils              == 2.7.0.0+    , text++-----------------------------+-- explicit fields plugin+-----------------------------++flag explicitFields+  description: Enable explicitFields plugin+  default:     True+  manual:      True++common explicitFields+  if flag(explicitFields)+    build-depends: haskell-language-server:hls-explicit-record-fields-plugin+    cpp-options: -DexplicitFields++library hls-explicit-record-fields-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.ExplicitFields+  build-depends:+    , base                  >=4.12 && <5+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lsp+    , lens+    , hls-graph+    , text+    , syb+    , transformers+    , containers+    , aeson+  hs-source-dirs:   plugins/hls-explicit-record-fields-plugin/src++  if flag(pedantic)+    ghc-options: -Wwarn=incomplete-record-updates++test-suite hls-explicit-record-fields-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-explicit-record-fields-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , text+    , haskell-language-server:hls-explicit-record-fields-plugin+    , hls-test-utils              == 2.7.0.0++-----------------------------+-- overloaded record dot plugin+-----------------------------++flag overloadedRecordDot+  description: Enable overloadedRecordDot plugin+  default:     True+  manual:      True++common overloadedRecordDot+  if flag(overloadedRecordDot)+    build-depends: haskell-language-server:hls-overloaded-record-dot-plugin+    cpp-options: -Dhls_overloaded_record_dot++library hls-overloaded-record-dot-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.OverloadedRecordDot+  build-depends:+    , base                  >=4.16 && <5+    , aeson+    , ghcide+    , hls-plugin-api+    , lsp+    , lens+    , hls-graph+    , text+    , syb+    , transformers+    , containers+    , deepseq+  hs-source-dirs:   plugins/hls-overloaded-record-dot-plugin/src++test-suite hls-overloaded-record-dot-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-overloaded-record-dot-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , text+    , haskell-language-server:hls-overloaded-record-dot-plugin+    , hls-test-utils              == 2.7.0.0+++-----------------------------+-- floskell plugin+-----------------------------++flag floskell+  description: Enable floskell plugin+  default:     True+  manual:      True++common floskell+  if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds))+    build-depends: haskell-language-server:hls-floskell-plugin+    cpp-options: -Dhls_floskell++library hls-floskell-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Floskell+  hs-source-dirs:   plugins/hls-floskell-plugin/src+  build-depends:+    , base            >=4.12 && <5+    , floskell        ^>=0.11.0+    , ghcide          == 2.7.0.0+    , hls-plugin-api  == 2.7.0.0+    , lsp-types       ^>=2.1+    , mtl+    , text+++test-suite hls-floskell-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-floskell-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-floskell-plugin+    , hls-test-utils       == 2.7.0.0++-----------------------------+-- fourmolu plugin+-----------------------------++flag fourmolu+  description: Enable fourmolu plugin+  default:     True+  manual:      True++common fourmolu+  if flag(fourmolu)+    build-depends: haskell-language-server:hls-fourmolu-plugin+    cpp-options: -Dhls_fourmolu++library hls-fourmolu-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Fourmolu+  hs-source-dirs:   plugins/hls-fourmolu-plugin/src+  build-depends:+    , base            >=4.12 && <5+    , filepath+    , fourmolu        ^>= 0.14 || ^>= 0.15+    , ghc-boot-th+    , ghcide          == 2.7.0.0+    , hls-plugin-api  == 2.7.0.0+    , lens+    , lsp+    , mtl+    , process-extras  >= 0.7.1+    , text+    , transformers+++test-suite hls-fourmolu-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-fourmolu-plugin/test+  main-is:          Main.hs+  build-tool-depends:+    fourmolu:fourmolu+  build-depends:+    , base            >=4.12 && <5+    , aeson+    , filepath+    , haskell-language-server:hls-fourmolu-plugin+    , hls-plugin-api+    , hls-test-utils       == 2.7.0.0+    , lsp-test++-----------------------------+-- ormolu plugin+-----------------------------++flag ormolu+  description: Enable ormolu plugin+  default:     True+  manual:      True++common ormolu+  if flag(ormolu)+    build-depends: haskell-language-server:hls-ormolu-plugin+    cpp-options: -Dhls_ormolu++library hls-ormolu-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.Ormolu+  hs-source-dirs:   plugins/hls-ormolu-plugin/src+  build-depends:+    , base            >=4.12  && <5+    , extra+    , filepath+    , ghc-boot-th+    , ghcide          == 2.7.0.0+    , hls-plugin-api  == 2.7.0.0+    , lsp+    , mtl+    , process-extras  >= 0.7.1+    , ormolu          ^>=0.1.2 || ^>= 0.2 || ^>= 0.3 || ^>= 0.5 || ^>= 0.6 || ^>= 0.7+    , text+    , transformers+++test-suite hls-ormolu-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-ormolu-plugin/test+  main-is:          Main.hs+  build-tool-depends:+    ormolu:ormolu+  build-depends:+    , base+    , aeson+    , filepath+    , haskell-language-server:hls-ormolu-plugin+    , hls-plugin-api+    , hls-test-utils     == 2.7.0.0+    , lsp-types+    , ormolu++-----------------------------+-- stylish-haskell plugin+-----------------------------++flag stylishHaskell+  description: Enable stylishHaskell plugin+  default:     True+  manual:      True++common stylishHaskell+  if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))+    build-depends: haskell-language-server:hls-stylish-haskell-plugin+    cpp-options: -Dhls_stylishHaskell++library hls-stylish-haskell-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Ide.Plugin.StylishHaskell+  hs-source-dirs:   plugins/hls-stylish-haskell-plugin/src+  build-depends:+    , base             >=4.12 && <5+    , directory+    , filepath+    , ghc-boot-th+    , ghcide           == 2.7.0.0+    , hls-plugin-api   == 2.7.0.0+    , lsp-types+    , mtl+    , stylish-haskell  ^>=0.12 || ^>=0.13 || ^>=0.14.2+    , text+++test-suite hls-stylish-haskell-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-stylish-haskell-plugin/test+  main-is:          Main.hs+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-stylish-haskell-plugin+    , hls-test-utils              == 2.7.0.0++-----------------------------+-- refactor plugin+-----------------------------++flag refactor+  description: Enable refactor plugin+  default:     True+  manual:      True++common refactor+  if flag(refactor)+    build-depends: haskell-language-server:hls-refactor-plugin+    cpp-options: -Dhls_refactor++library hls-refactor-plugin+  import:           defaults, pedantic, warnings+  exposed-modules:  Development.IDE.GHC.ExactPrint+                    Development.IDE.GHC.Compat.ExactPrint+                    Development.IDE.Plugin.CodeAction+                    Development.IDE.Plugin.CodeAction.Util+                    Development.IDE.GHC.Dump+  other-modules:    Development.IDE.Plugin.CodeAction.Args+                    Development.IDE.Plugin.CodeAction.ExactPrint+                    Development.IDE.Plugin.CodeAction.PositionIndexed+                    Development.IDE.Plugin.Plugins.AddArgument+                    Development.IDE.Plugin.Plugins.Diagnostic+                    Development.IDE.Plugin.Plugins.FillHole+                    Development.IDE.Plugin.Plugins.FillTypeWildcard+                    Development.IDE.Plugin.Plugins.ImportUtils+  default-extensions:+    CPP+    DataKinds+    DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    ExplicitNamespaces+    FunctionalDependencies+    LambdaCase+    OverloadedStrings+    PatternSynonyms+    RecordWildCards+    ViewPatterns+  hs-source-dirs:   plugins/hls-refactor-plugin/src+  build-depends:+    , base                  >=4.12 && <5+    , ghc+    , bytestring+    , ghc-boot+    , regex-tdfa+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lsp+    , text+    , transformers+    , unordered-containers+    , containers+    , ghc-exactprint < 1 || >= 1.4+    , extra+    , retrie+    , syb+    , hls-graph+    , dlist+    , deepseq+    , mtl+    , lens+    , data-default+    , time+    -- FIXME: Only needed to workaround for qualified imports in GHC 9.4+    , regex-applicative+    , parser-combinators++test-suite hls-refactor-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-refactor-plugin/test+  main-is:          Main.hs+  other-modules:    Test.AddArgument+  ghc-options:      -O0+  build-depends:+    , base+    , filepath+    , haskell-language-server:hls-refactor-plugin+    , hls-test-utils      == 2.7.0.0+    , lens+    , lsp-types+    , text+    , hls-plugin-api+    , parser-combinators+    , data-default+    , extra+    , ghcide:{ghcide, ghcide-test-utils}+    , shake+    , hls-plugin-api+    , lsp-test+    , directory+    , regex-tdfa+    , tasty-hunit+    , tasty-expected-failure+    , tasty++-----------------------------+-- semantic tokens plugin+-----------------------------++flag semanticTokens+  description: Enable semantic tokens plugin+  default:     True+  manual:      True++common semanticTokens+  if flag(semanticTokens)+    build-depends: haskell-language-server:hls-semantic-tokens-plugin+    cpp-options: -Dhls_semanticTokens++library hls-semantic-tokens-plugin+  import: defaults, pedantic, warnings+  buildable: True+  exposed-modules:+    Ide.Plugin.SemanticTokens+    Ide.Plugin.SemanticTokens.Types+    Ide.Plugin.SemanticTokens.Mappings+  other-modules:+    Ide.Plugin.SemanticTokens.Query+    Ide.Plugin.SemanticTokens.SemanticConfig+    Ide.Plugin.SemanticTokens.Utils+    Ide.Plugin.SemanticTokens.Tokenize+    Ide.Plugin.SemanticTokens.Internal++  hs-source-dirs:     plugins/hls-semantic-tokens-plugin/src+  build-depends:+    , base                  >=4.12 && <5+    , containers+    , extra+    , text-rope+    , mtl                   >= 2.2+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , lens+    , lsp                    >=2.4+    , text+    , transformers+    , bytestring+    , syb+    , array+    , deepseq+    , dlist+    , hls-graph == 2.7.0.0+    , template-haskell+    , data-default+    , stm+    , stm-containers++  default-extensions: DataKinds++test-suite hls-semantic-tokens-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-semantic-tokens-plugin/test+  main-is:          SemanticTokensTest.hs++  build-depends:+    , aeson+    , base+    , containers+    , filepath+    , haskell-language-server:hls-semantic-tokens-plugin+    , hls-test-utils              == 2.7.0.0+    , ghcide:ghcide-test-utils+    , hls-plugin-api+    , lens+    , lsp+    , text-rope+    , lsp-test+    , text+    , data-default+    , ghcide                == 2.7.0.0+    , hls-plugin-api        == 2.7.0.0+    , data-default+    , row-types++----------------------------+----------------------------+-- HLS+----------------------------+----------------------------++library+  import:           defaults+                  , warnings+                  , pedantic+                  -- plugins+                  , cabal+                  , callHierarchy+                  , cabalfmt+                  , changeTypeSignature+                  , class+                  , eval+                  , importLens+                  , rename+                  , retrie+                  , hlint+                  , stan+                  , moduleName+                  , pragmas+                  , splice+                  , alternateNumberFormat+                  , qualifyImportedNames+                  , codeRange+                  , gadt+                  , explicitFixity+                  , explicitFields+                  , floskell+                  , fourmolu+                  , ormolu+                  , stylishHaskell+                  , refactor+                  , overloadedRecordDot+                  , semanticTokens++  exposed-modules:+    Ide.Arguments+    Ide.Main+    Ide.Version+    HlsPlugins++  other-modules:    Paths_haskell_language_server+  autogen-modules:  Paths_haskell_language_server+  hs-source-dirs:   src+  build-depends:+    , aeson-pretty+    , base                  >=4.16 && <5+    , data-default+    , directory+    , extra+    , filepath+    , ghc+    , ghcide                == 2.7.0.0+    , githash               >=0.1.6.1+    , hie-bios+    , hls-plugin-api        == 2.7.0.0+    , optparse-applicative+    , optparse-simple+    , prettyprinter         >= 1.7+    , process+    , text++  default-extensions: DataKinds++executable haskell-language-server+  import:           defaults+                  , warnings+                  , pedantic+  main-is:          Main.hs+  hs-source-dirs:   exe++  ghc-options:+    -threaded+    -- allow user RTS overrides+    -rtsopts+    -- disable idle GC+    -- increase nursery size+    -- Enable collection of heap statistics+    "-with-rtsopts=-I0 -A128M -T"+  if flag(pedantic)+    ghc-options: -Werror+  if !os(windows) && flag(dynamic)+  -- We want to link against the dyn rts just like official GHC binaries do;+  --   the linked rts determines how external libs are loaded dynamically by TH.+  -- The standard way of doing this is via the --enable-dynamic-executables Cabal option+  -- Unfortunately it doesnt' work, see https://github.com/haskell/haskell-language-server/issues/2659+  -- One can use --ghc-options=-dynamic but this gets applied to the dependencies as well,+  -- which results in massive rebuilds and incompatibilities with profiling.+  -- So instead we set the -dynamic flag diretly here.+    ghc-options: -dynamic++  build-depends:+    , base                    >=4.16 && <5+    , haskell-language-server+    , hls-plugin-api+    , lsp+    , prettyprinter           >= 1.7+    , text++  default-extensions: DataKinds++executable haskell-language-server-wrapper+  import:           defaults+                  , warnings+                  , pedantic+  main-is:          Wrapper.hs+  hs-source-dirs:   exe+  other-modules:    Paths_haskell_language_server+  autogen-modules:  Paths_haskell_language_server+  ghc-options:+    -threaded+    -- allow user RTS overrides+    -rtsopts+    -- disable idle GC+    -- increase nursery size+    "-with-rtsopts=-I0 -A128M"++  build-depends:+    , base       >=4.16 && <5+    , data-default+    , directory+    , extra+    , filepath+    , ghcide+    , haskell-language-server+    , hie-bios+    , hls-plugin-api+    , lsp+    , lsp-types+    , text+    , transformers+    , unliftio-core+  if !os(windows)+      build-depends:+        , unix+        , containers+  else+      build-depends:+        , process++test-suite func-test+  import:             defaults+                    , test-defaults+                    , warnings+                    , pedantic+                    , refactor+  type:               exitcode-stdio-1.0+  build-tool-depends:+    haskell-language-server:haskell-language-server,+    ghcide:ghcide-test-preprocessor++  build-depends:+    , aeson+    , base            >=4.16 && <5+    , bytestring+    , containers+    , deepseq+    , extra+    , filepath+    , ghcide:{ghcide, ghcide-test-utils}+    , hashable+    , hls-plugin-api+    , hls-test-utils == 2.7.0.0+    , lens+    , lsp-test+    , lsp-types+    , text+    , unordered-containers++  hs-source-dirs:     test/functional test/utils++  main-is:            Main.hs+  other-modules:+    Config+    ConfigSchema+    Format+    FunctionalBadProject+    HieBios+    Progress+    Test.Hls.Command+    Test.Hls.Flags++  default-extensions: OverloadedStrings++-- Duplicating inclusion plugin conditions until tests are moved to their own packages+  if flag(eval)+    cpp-options: -Dhls_eval+-- formatters+  if flag(floskell)+    cpp-options: -Dhls_floskell+  if flag(fourmolu)+    cpp-options: -Dhls_fourmolu+  if flag(ormolu)+    cpp-options: -Dhls_ormolu++test-suite wrapper-test+  import:             defaults+                    , warnings+                    , pedantic+  type:               exitcode-stdio-1.0+  build-tool-depends:+    haskell-language-server:haskell-language-server-wrapper,+    haskell-language-server:haskell-language-server++  build-depends:+    , base       >=4.16 && <5+    , extra+    , hls-test-utils              == 2.7.0.0+    , process++  hs-source-dirs:     test/wrapper+  main-is:            Main.hs++benchmark benchmark+    import:           defaults, warnings+    -- Depends on shake-bench which is unbuildable after this point+    if impl(ghc >= 9.5)+      buildable: False+    type: exitcode-stdio-1.0+    ghc-options: -threaded+    main-is: Main.hs+    hs-source-dirs: bench+    build-tool-depends:+        ghcide-bench:ghcide-bench,+        hp2pretty:hp2pretty,+        implicit-hie:gen-hie+    default-extensions:+        LambdaCase+        RecordWildCards+        ViewPatterns++    build-depends:+      , aeson+      , base       >=4.16 && <5+      , containers+      , data-default+      , directory+      , extra+      , filepath+      , ghcide-bench+      , haskell-language-server+      , hls-plugin-api+      , lens+      , lens-aeson+      , shake+      , shake-bench == 0.2.*+      , text+      , yaml
+ plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DataKinds    #-}+{-# LANGUAGE TypeFamilies #-}+module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where++import           Control.Lens                     ((^.))+import           Control.Monad.Except             (ExceptT)+import           Control.Monad.IO.Class           (MonadIO)+import qualified Data.Map                         as Map+import           Data.Text                        (Text, unpack)+import qualified Data.Text                        as T+import           Development.IDE                  (GetParsedModule (GetParsedModule),+                                                   IdeState, RuleResult, Rules,+                                                   define, realSrcSpanToRange,+                                                   use)+import           Development.IDE.Core.PluginUtils+import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.GHC.Compat       hiding (getSrcSpan)+import           Development.IDE.GHC.Util         (getExtensions)+import           Development.IDE.Graph.Classes    (Hashable, NFData, rnf)+import           Development.IDE.Spans.Pragmas    (NextPragmaInfo,+                                                   getFirstPragma,+                                                   insertNewPragma)+import           GHC.Generics                     (Generic)+import           Ide.Logger                       as Logger+import           Ide.Plugin.Conversion            (AlternateFormat,+                                                   ExtensionNeeded (NeedsExtension, NoExtension),+                                                   alternateFormat)+import           Ide.Plugin.Error+import           Ide.Plugin.Literals+import           Ide.Plugin.RangeMap              (RangeMap)+import qualified Ide.Plugin.RangeMap              as RangeMap+import           Ide.Types+import qualified Language.LSP.Protocol.Lens       as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types++newtype Log = LogShake Shake.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogShake msg -> pretty msg++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder pId = (defaultPluginDescriptor pId "Provides code actions to convert numeric literals to different formats")+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler+    , pluginRules = collectLiteralsRule recorder+    }++data CollectLiterals = CollectLiterals+                     deriving (Show, Eq, Generic)++instance Hashable CollectLiterals+instance NFData CollectLiterals++type instance RuleResult CollectLiterals = CollectLiteralsResult++data CollectLiteralsResult = CLR+    { literals          :: RangeMap Literal+    , enabledExtensions :: [GhcExtension]+    } deriving (Generic)++newtype GhcExtension = GhcExtension { unExt :: Extension }++instance NFData GhcExtension where+    rnf x = x `seq` ()++instance Show CollectLiteralsResult where+    show _ = "<CollectLiteralResult>"++instance NFData CollectLiteralsResult++collectLiteralsRule :: Recorder (WithPriority Log) -> Rules ()+collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do+    pm <- use GetParsedModule nfp+    -- get the current extensions active and transform them into FormatTypes+    let exts = map GhcExtension . getExtensions <$> pm+        -- collect all the literals for a file+        lits = collectLiterals . pm_parsed_source <$> pm+        litMap = RangeMap.fromList (realSrcSpanToRange . getSrcSpan) <$> lits+    pure ([], CLR <$> litMap <*> exts)++codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do+    nfp <- getNormalizedFilePathE (docId ^. L.uri)+    CLR{..} <- requestLiterals pId state nfp+    pragma <- getFirstPragma pId state nfp+        -- remove any invalid literals (see validTarget comment)+    let litsInRange = RangeMap.filterByRange currRange literals+        -- generate alternateFormats and zip with the literal that generated the alternates+        literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange+        -- make a code action for every literal and its' alternates (then flatten the result)+        actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs+    pure $ InL actions+    where+        mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction+        mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction {+            _title = mkCodeActionTitle lit af enabled+            , _kind = Just $ CodeActionKind_Custom "quickfix.literals.style"+            , _diagnostics = Nothing+            , _isPreferred = Nothing+            , _disabled = Nothing+            , _edit = Just $ mkWorkspaceEdit nfp edits+            , _command = Nothing+            , _data_ = Nothing+            }+            where+                edits =  [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit+                pragmaEdit = case ext of+                    NeedsExtension ext' -> [insertNewPragma npi ext' | needsExtension ext' enabled]+                    NoExtension         -> []++        mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit+        mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing+            where+                changes = Just $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, edits)]++mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text+mkCodeActionTitle lit (alt, ext) ghcExts+    | (NeedsExtension ext') <- ext+    , needsExtension ext' ghcExts = title <> " (needs extension: " <> T.pack (show ext') <> ")"+    | otherwise = title+    where+        title = "Convert " <> getSrcText lit <> " into " <> alt+++-- | Checks whether the extension given is already enabled+needsExtension :: Extension -> [GhcExtension] -> Bool+needsExtension ext ghcExts = ext `notElem` map unExt ghcExts++requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult+requestLiterals (PluginId pId) state =+    runActionE (unpack pId <> ".CollectLiterals") state+    . useE CollectLiterals
+ plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}+module Ide.Plugin.Conversion (+    alternateFormat+    , hexRegex+    , hexFloatRegex+    , binaryRegex+    , octalRegex+    , decimalRegex+    , numDecimalRegex+    , matchLineRegex+    , toOctal+    , toDecimal+    , toBinary+    , toHex+    , toFloatDecimal+    , toFloatExpDecimal+    , toHexFloat+    , AlternateFormat+    , ExtensionNeeded(..)+) where++import           Data.List                     (delete)+import           Data.List.Extra               (enumerate, upper)+import           Data.Maybe                    (mapMaybe)+import           Data.Ratio                    (denominator, numerator)+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Development.IDE.Graph.Classes (NFData)+import           GHC.Generics                  (Generic)+import           GHC.LanguageExtensions.Type   (Extension (..))+import           GHC.Show                      (intToDigit)+import           Ide.Plugin.Literals           (Literal (..), getSrcText)+import           Numeric+import           Text.Regex.TDFA               ((=~))++data FormatType = IntFormat IntFormatType+                | FracFormat FracFormatType+                | NoFormat+                deriving (Show, Eq, Generic)++instance NFData FormatType++data IntFormatType = IntDecimalFormat+                   | HexFormat+                   | OctalFormat+                   | BinaryFormat+                   | NumDecimalFormat+                   deriving (Show, Eq, Generic, Bounded, Enum)++instance NFData IntFormatType++data FracFormatType = FracDecimalFormat+                    | HexFloatFormat+                    | ExponentFormat+                    deriving (Show, Eq, Generic, Bounded, Enum)++instance NFData FracFormatType++data ExtensionNeeded = NoExtension+                     | NeedsExtension Extension++type AlternateFormat = (Text, ExtensionNeeded)++-- | Generate alternate formats for a single Literal based on FormatType's given.+alternateFormat :: Literal -> [AlternateFormat]+alternateFormat lit = case lit of+  IntLiteral _ _ val   -> map (alternateIntFormat val) (removeCurrentFormatInt lit)+  FracLiteral _ _  val -> if denominator val == 1 -- floats that can be integers we can represent as ints+      then map (alternateIntFormat (numerator val)) (removeCurrentFormatInt lit)+      else map (alternateFracFormat val) (removeCurrentFormatFrac lit)++alternateIntFormat :: Integer -> IntFormatType -> AlternateFormat+alternateIntFormat val = \case+    IntDecimalFormat -> (T.pack $ toDecimal val, NoExtension)+    HexFormat        -> (T.pack $ toHex val, NoExtension)+    OctalFormat      -> (T.pack $ toOctal val, NoExtension)+    BinaryFormat     -> (T.pack $ toBinary val, NeedsExtension BinaryLiterals)+    NumDecimalFormat -> (T.pack $ toFloatExpDecimal (fromInteger @Double val), NeedsExtension NumDecimals)++alternateFracFormat :: Rational -> FracFormatType -> AlternateFormat+alternateFracFormat val = \case+  FracDecimalFormat -> (T.pack $ toFloatDecimal (fromRational @Double val), NoExtension)+  ExponentFormat    -> (T.pack $ toFloatExpDecimal (fromRational @Double val), NoExtension)+  HexFloatFormat    -> (T.pack $ toHexFloat (fromRational @Double val), NeedsExtension HexFloatLiterals)++-- given a Literal compute it's current Format and delete it from the list of available formats+removeCurrentFormat :: (Foldable t, Eq a) => [a] -> t a -> [a]+removeCurrentFormat fmts toRemove = foldl (flip delete) fmts toRemove++removeCurrentFormatInt :: Literal -> [IntFormatType]+removeCurrentFormatInt (getSrcText -> srcText) = removeCurrentFormat intFormats (filterIntFormats $ sourceToFormatType srcText)++removeCurrentFormatFrac :: Literal -> [FracFormatType]+removeCurrentFormatFrac (getSrcText -> srcText) = removeCurrentFormat fracFormats (filterFracFormats $ sourceToFormatType srcText)++filterIntFormats :: [FormatType] -> [IntFormatType]+filterIntFormats = mapMaybe getIntFormat+    where+        getIntFormat (IntFormat f) = Just f+        getIntFormat _             = Nothing++filterFracFormats :: [FormatType] -> [FracFormatType]+filterFracFormats = mapMaybe getFracFormat+    where+        getFracFormat (FracFormat f) = Just f+        getFracFormat _              = Nothing++intFormats :: [IntFormatType]+intFormats = enumerate++fracFormats :: [FracFormatType]+fracFormats = enumerate++-- | Regex to match a Haskell Hex Literal+hexRegex :: Text+hexRegex = "0[xX][a-fA-F0-9]+"++-- | Regex to match a Haskell Hex Float Literal+hexFloatRegex :: Text+hexFloatRegex = "0[xX][a-fA-F0-9]+(\\.)?[a-fA-F0-9]*(p[+-]?[0-9]+)?"++-- | Regex to match a Haskell Binary Literal+binaryRegex :: Text+binaryRegex = "0[bB][0|1]+"++-- | Regex to match a Haskell Octal Literal+octalRegex :: Text+octalRegex = "0[oO][0-8]+"++-- | Regex to match a Haskell Decimal Literal (no decimal points)+decimalRegex :: Text+decimalRegex = "[0-9]+(\\.[0-9]+)?"++-- | Regex to match a Haskell Literal with an explicit exponent+numDecimalRegex :: Text+numDecimalRegex = "[0-9]+\\.[0-9]+[eE][+-]?[0-9]+"++-- we want to be explicit in our matches+-- so we need to match the beginning/end of the source text+-- | Wraps a Regex with a beginning ("^") and end ("$") token+matchLineRegex :: Text -> Text+matchLineRegex regex = "^" <> regex <> "$"++sourceToFormatType :: Text -> [FormatType]+sourceToFormatType srcText+    | srcText =~ matchLineRegex hexRegex = [IntFormat HexFormat]+    | srcText =~ matchLineRegex hexFloatRegex = [FracFormat HexFloatFormat]+    | srcText =~ matchLineRegex octalRegex = [IntFormat OctalFormat]+    | srcText =~ matchLineRegex binaryRegex = [IntFormat BinaryFormat]+    -- can either be a NumDecimal or just a regular Fractional with an exponent+    -- otherwise we wouldn't need to return a list+    | srcText =~ matchLineRegex numDecimalRegex  = [IntFormat NumDecimalFormat, FracFormat ExponentFormat]+    -- just assume we are in base 10 with no decimals+    | otherwise = [IntFormat IntDecimalFormat, FracFormat FracDecimalFormat]++toBase :: (Num a, Ord a) => (a -> ShowS) -> String -> a -> String+toBase conv header n+  | n < 0 = '-' : header <> upper (conv (abs n) "")+  | otherwise = header <> upper (conv n "")++#if MIN_VERSION_base(4,17,0)+toOctal, toDecimal, toBinary, toHex :: Integral a => a -> String+#else+toOctal, toDecimal, toBinary, toHex:: (Integral a, Show a) => a -> String+#endif++toBinary = toBase showBin_ "0b"+  where+    -- this is not defined in base < 4.16+    showBin_ = showIntAtBase 2 intToDigit++toOctal = toBase showOct "0o"++toDecimal = toBase showInt ""++toHex = toBase showHex "0x"++toFloatDecimal :: RealFloat a => a -> String+toFloatDecimal val = showFFloat Nothing val ""++toFloatExpDecimal :: RealFloat a => a -> String+toFloatExpDecimal val = showEFloat Nothing val ""++toHexFloat :: RealFloat a => a -> String+toHexFloat val = showHFloat val ""
+ plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}+module Ide.Plugin.Literals (+    collectLiterals+    , Literal(..)+    , getSrcText+    , getSrcSpan+) where++import           Data.Maybe                    (maybeToList)+import           Data.Text                     (Text)+import qualified Data.Text                     as T+#if __GLASGOW_HASKELL__ >= 908+import qualified Data.Text.Encoding            as T+#endif+import           Development.IDE.GHC.Compat    hiding (getSrcSpan)+import           Development.IDE.Graph.Classes (NFData (rnf))+import           Generics.SYB                  (Data, everything, extQ)+import qualified GHC.Generics                  as GHC++-- data type to capture what type of literal we are dealing with+-- provides location and possibly source text (for OverLits) as well as it's value+-- we currently don't have any use for PrimLiterals. They never have source text so we always drop them+-- | Captures a Numeric Literals Location, Source Text, and Value.+data Literal = IntLiteral  LiteralSrcSpan Text Integer+             | FracLiteral LiteralSrcSpan Text Rational+             deriving (GHC.Generic, Show, Ord, Eq, Data)++newtype LiteralSrcSpan = LiteralSrcSpan { unLit :: RealSrcSpan }+                        deriving (GHC.Generic, Show, Ord, Eq, Data)++instance NFData LiteralSrcSpan where+    rnf x = x `seq` ()++instance NFData Literal+++-- | Return a Literal's Source representation+getSrcText :: Literal -> Text+getSrcText = \case+  IntLiteral _ txt _  -> txt+  FracLiteral _ txt _ -> txt++-- | Return a Literal's Real Source location+getSrcSpan :: Literal -> RealSrcSpan+getSrcSpan = \case+    IntLiteral ss _ _  -> unLit ss+    FracLiteral ss _ _ -> unLit ss++-- | Find all literals in a Parsed Source File+collectLiterals :: Data ast => ast -> [Literal]+collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern))+++-- | Translate from HsLit and HsOverLit Types to our Literal Type+getLiteral :: LHsExpr GhcPs -> Maybe Literal+getLiteral (L (locA -> (RealSrcSpan sSpan _)) expr) = case expr of+    HsLit _ lit         -> fromLit lit sSpan+    HsOverLit _ overLit -> fromOverLit overLit sSpan+    _                   -> Nothing+getLiteral _ = Nothing++-- | Destructure Patterns to unwrap any Literals+getPattern :: LPat GhcPs -> Maybe Literal+getPattern (L (locA -> (RealSrcSpan patSpan _)) pat) = case pat of+    LitPat _ lit -> case lit of+        HsInt _ val   -> fromIntegralLit patSpan val+        HsRat _ val _ -> fromFractionalLit patSpan val+        _             -> Nothing+#if __GLASGOW_HASKELL__ == 902+    NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan+    NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan+#else+    NPat _ (L (locA -> (RealSrcSpan sSpan _)) overLit) _ _ -> fromOverLit overLit sSpan+    NPlusKPat _ _ (L (locA -> (RealSrcSpan sSpan _)) overLit1) _ _ _ -> fromOverLit overLit1 sSpan+#endif+    _ -> Nothing+getPattern _ = Nothing++fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal+fromLit lit sSpan = case lit of+        HsInt _ val   -> fromIntegralLit sSpan val+        HsRat _ val _ -> fromFractionalLit sSpan val+        _             -> Nothing++fromOverLit :: HsOverLit p -> RealSrcSpan -> Maybe Literal+fromOverLit OverLit{..} sSpan = case ol_val of+        HsIntegral il   -> fromIntegralLit sSpan il+        HsFractional fl -> fromFractionalLit sSpan fl+        _               -> Nothing+fromOverLit _ _ = Nothing++fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal+fromIntegralLit s IL{..} = fmap (\txt' -> IntLiteral (LiteralSrcSpan s) txt' il_value) (fromSourceText il_text)++fromFractionalLit  :: RealSrcSpan -> FractionalLit -> Maybe Literal+fromFractionalLit s fl@FL{fl_text} = fmap (\txt' -> FracLiteral (LiteralSrcSpan s) txt' (rationalFromFractionalLit fl)) (fromSourceText fl_text)++fromSourceText :: SourceText -> Maybe Text+fromSourceText = \case+#if __GLASGOW_HASKELL__ >= 908+  SourceText s -> Just $ T.decodeUtf8 $ bytesFS s+#else+  SourceText s -> Just $ T.pack s+#endif+  NoSourceText -> Nothing
+ plugins/hls-alternate-number-format-plugin/test/Main.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE ViewPatterns #-}+module Main ( main ) where++import           Data.Either                      (rights)+import           Data.List                        (find)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat+import qualified Ide.Plugin.Conversion            as Conversion+import           Properties.Conversion            (conversions)+import           System.FilePath                  ((<.>), (</>))+import           Test.Hls+import           Text.Regex.TDFA                  ((=~))++main :: IO ()+main = defaultTestRunner test++alternateNumberFormatPlugin :: PluginTestDescriptor AlternateNumberFormat.Log+alternateNumberFormatPlugin = mkPluginTestDescriptor AlternateNumberFormat.descriptor "alternateNumberFormat"++-- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time.+-- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something+-- to do with how+test :: TestTree+test = testGroup "alternateNumberFormat" [+    codeActionHex "TIntDtoH" 3 13+    , codeActionOctal "TIntDtoO" 3 13+    , codeActionBinary "TIntDtoB" 4 13+    , codeActionNumDecimal "TIntDtoND" 5 13+    , codeActionFracExp "TFracDtoE" 3 13+    , codeActionFloatHex "TFracDtoHF" 4 13+    , codeActionDecimal "TIntHtoD" 3 13+    , codeActionDecimal "TFracHFtoD" 4 13+    -- to test we don't duplicate pragmas+    , codeActionFloatHex "TFracDtoHFWithPragma" 4 13+    , codeActionProperties "TFindLiteralIntPattern" [(4, 25), (5,25)] $ \actions -> do+        liftIO $ length actions @?= 8+    , codeActionProperties "TFindLiteralIntCase" [(4, 29)] $ \actions -> do+        liftIO $ length actions @?= 4+    , codeActionProperties "TFindLiteralIntCase2" [(5, 21)] $ \actions -> do+        liftIO $ length actions @?= 4+    , codeActionProperties "TFindLiteralDoReturn" [(6, 10)] $ \actions -> do+        liftIO $ length actions @?= 4+    , codeActionProperties "TFindLiteralDoLet" [(6, 13), (7, 13)] $ \actions -> do+        liftIO $ length actions @?= 8+    , codeActionProperties "TFindLiteralList" [(4, 28)] $ \actions -> do+        liftIO $ length actions @?= 4+    , conversions+    ]++codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree+codeActionProperties fp locs assertions = testCase fp $ do+    runSessionWithServer def alternateNumberFormatPlugin testDataDir $ do+        openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findAlternateNumberActions >>= assertions+    where+        -- similar to codeActionTest+        codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs++findAlternateNumberActions :: [Command |? CodeAction] -> Session [CodeAction]+findAlternateNumberActions = pure . filter isAlternateNumberCodeAction . rights . map toEither+    where+        isAlternateNumberCodeAction CodeAction{_kind} = case _kind of+          Nothing -> False+          Just kind -> case kind of+            CodeActionKind_Custom txt -> txt == "quickfix.literals.style"+            _                         -> False++-- most helpers derived from explicit-imports-plugin Main Test file++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-alternate-number-format-plugin" </> "test" </> "testdata"++goldenAlternateFormat :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenAlternateFormat fp = goldenWithHaskellDoc def alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs"++codeActionTest :: (Maybe Text -> Bool) -> FilePath -> Int -> Int -> TestTree+codeActionTest filter' fp line col = goldenAlternateFormat fp $ \doc -> do+  actions <- getCodeActions doc (pointRange line col)+  -- can't generate code actions?+  case find (filter' . codeActionTitle) actions of+    Just (InR x) -> executeCodeAction x+    _            -> liftIO $ assertFailure "Unable to find CodeAction"++codeActionDecimal :: FilePath -> Int -> Int -> TestTree+codeActionDecimal = codeActionTest isDecimalCodeAction++codeActionHex :: FilePath -> Int -> Int -> TestTree+codeActionHex = codeActionTest isHexCodeAction++codeActionOctal :: FilePath -> Int -> Int -> TestTree+codeActionOctal = codeActionTest isOctalCodeAction++codeActionBinary :: FilePath -> Int -> Int -> TestTree+codeActionBinary = codeActionTest isBinaryCodeAction++codeActionNumDecimal :: FilePath -> Int -> Int -> TestTree+codeActionNumDecimal = codeActionTest isNumDecimalCodeAction++codeActionFracExp :: FilePath -> Int -> Int -> TestTree+codeActionFracExp = codeActionTest isNumDecimalCodeAction++codeActionFloatHex :: FilePath -> Int -> Int -> TestTree+codeActionFloatHex = codeActionTest isHexFloatCodeAction++codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle (InR CodeAction {_title}) = Just _title+codeActionTitle _                         = Nothing++pointRange :: Int -> Int -> Range+pointRange+  (subtract 1 -> fromIntegral -> line)+  (subtract 1 -> fromIntegral -> col) =+    Range (Position line col) (Position line $ col + 1)++convertPrefix, intoInfix, maybeExtension, hexRegex, hexFloatRegex, binaryRegex, octalRegex, numDecimalRegex, decimalRegex :: Text+convertPrefix = "Convert (" <> T.intercalate "|" [Conversion.hexRegex, Conversion.hexFloatRegex, Conversion.binaryRegex, Conversion.octalRegex, Conversion.numDecimalRegex, Conversion.decimalRegex] <> ")"+intoInfix = " into "+maybeExtension = "( \\(needs extension: .*)?"+hexRegex = intoInfix <> Conversion.hexRegex <> maybeExtension+hexFloatRegex = intoInfix <> Conversion.hexFloatRegex <> maybeExtension+binaryRegex = intoInfix <> Conversion.binaryRegex <> maybeExtension+octalRegex = intoInfix <> Conversion.octalRegex <> maybeExtension+numDecimalRegex = intoInfix <> Conversion.numDecimalRegex <> maybeExtension+decimalRegex = intoInfix <> Conversion.decimalRegex <> maybeExtension++isCodeAction :: Text -> Maybe Text -> Bool+isCodeAction userRegex (Just txt) = txt =~ Conversion.matchLineRegex (convertPrefix <> userRegex)+isCodeAction _ _                  = False++isHexCodeAction :: Maybe Text -> Bool+isHexCodeAction = isCodeAction hexRegex++isHexFloatCodeAction :: Maybe Text -> Bool+isHexFloatCodeAction = isCodeAction hexFloatRegex++isBinaryCodeAction :: Maybe Text -> Bool+isBinaryCodeAction = isCodeAction binaryRegex++isOctalCodeAction :: Maybe Text -> Bool+isOctalCodeAction = isCodeAction octalRegex++-- This can match EITHER an integer as NumDecimal extension or a Fractional+-- as in 1.23e-3 (so anything with an exponent really)+isNumDecimalCodeAction :: Maybe Text -> Bool+isNumDecimalCodeAction = isCodeAction numDecimalRegex++isDecimalCodeAction :: Maybe Text -> Bool+isDecimalCodeAction = isCodeAction decimalRegex
+ plugins/hls-alternate-number-format-plugin/test/Properties/Conversion.hs view
@@ -0,0 +1,42 @@+module Properties.Conversion where++import           Ide.Plugin.Conversion+import           Test.Hls              (TestTree, testGroup)+import           Test.Tasty.QuickCheck (testProperty)+import           Text.Regex.TDFA       ((=~))++conversions :: TestTree+conversions = testGroup "Conversions" $+    map (uncurry testProperty)+    [ ("Match NumDecimal", prop_regexMatchesNumDecimal)+    , ("Match Hex", prop_regexMatchesHex)+    , ("Match Octal", prop_regexMatchesOctal)+    , ("Match Binary", prop_regexMatchesBinary)+    ]+    <>+    map (uncurry testProperty)+    [ ("Match HexFloat", prop_regexMatchesHexFloat)+    , ("Match FloatDecimal", prop_regexMatchesFloatDecimal)+    , ("Match FloatExpDecimal", prop_regexMatchesFloatExpDecimal)+    ]++prop_regexMatchesNumDecimal :: Integer -> Bool+prop_regexMatchesNumDecimal = (=~ numDecimalRegex) . toFloatExpDecimal @Double . fromInteger++prop_regexMatchesHex :: Integer -> Bool+prop_regexMatchesHex = (=~ hexRegex ) . toHex++prop_regexMatchesOctal :: Integer -> Bool+prop_regexMatchesOctal = (=~ octalRegex) . toOctal++prop_regexMatchesBinary :: Integer -> Bool+prop_regexMatchesBinary = (=~ binaryRegex) . toBinary++prop_regexMatchesHexFloat :: Double -> Bool+prop_regexMatchesHexFloat = (=~ hexFloatRegex) . toHexFloat++prop_regexMatchesFloatDecimal :: Double -> Bool+prop_regexMatchesFloatDecimal = (=~ decimalRegex ) . toFloatDecimal++prop_regexMatchesFloatExpDecimal :: Double -> Bool+prop_regexMatchesFloatExpDecimal = (=~ numDecimalRegex ) . toFloatExpDecimal
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralDoLet where++doLet :: IO ()+doLet = do+    let x = 199+        y = 144+    pure ()
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralDoReturn where++doReturn :: IO Integer+doReturn = do+    pure 54
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralIntCase where++caseExpression x = case x + 34 of+                    _ -> "testing if we find a literal in the case statement"
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralIntCase where++caseExpression x = case x of+                    57 -> "testing to find literals in matching cases"+                    _  -> ""
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralIntPattern where++patternMatchingFunction 1 = "one"+patternMatchingFunction 2 = "two"+patternMatchingFunction _ = "the rest of the numbers"
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE NoBinaryLiterals #-}+module TFindLiteralList where++listTest = [reverse $ show 57]
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.expected.hs view
@@ -0,0 +1,3 @@+module TFracDtoE where++convertMe = 1.2345e2
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.hs view
@@ -0,0 +1,3 @@+module TFracDtoE where++convertMe = 123.45
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE HexFloatLiterals #-}+module TFracDtoHF where++convertMe = 0x1.edccccccccccdp6
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE Haskell2010 #-}+module TFracDtoHF where++convertMe = 123.45
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.expected.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE HexFloatLiterals #-}+module TFracDtoHFWithPragma where++convertMe = 0x1.edccccccccccdp6
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE HexFloatLiterals #-}+module TFracDtoHFWithPragma where++convertMe = 123.45
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.expected.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE HexFloatLiterals #-}+module TFracDtoHF where++convertMe = 123.45
+ plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE HexFloatLiterals #-}+module TFracDtoHF where++convertMe = 0x1.edccccccccccdp6
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE BinaryLiterals #-}+module TIntDtoB where++convertMe = 0b1100
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE Haskell2010 #-}+module TIntDtoB where++convertMe = 12
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.expected.hs view
@@ -0,0 +1,3 @@+module TIntDtoH where++convertMe = 0xC
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.hs view
@@ -0,0 +1,3 @@+module TIntDtoH where++convertMe = 12
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE NumDecimals #-}+module TIntDtoND where++convertMe :: Integer+convertMe = 1.25345e5
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE Haskell2010 #-}+module TIntDtoND where++convertMe :: Integer+convertMe = 125345
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.expected.hs view
@@ -0,0 +1,3 @@+module TIntDtoO where++convertMe = 0o14
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.hs view
@@ -0,0 +1,3 @@+module TIntDtoO where++convertMe = 12
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.expected.hs view
@@ -0,0 +1,3 @@+module TIntDtoH where++convertMe = 12
+ plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.hs view
@@ -0,0 +1,3 @@+module TIntDtoH where++convertMe = 0xC
+ plugins/hls-alternate-number-format-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,25 @@+cradle:+  direct:+    arguments:+      - -i+      - -i.+      - TIntDtoH+      - TIntDtoB+      - TIntDtoO+      - TIntDtoND+      - TFracDtoE+      - TFracDtoHF+      - TFracDtoHFWithPragma+      - TIntHtoD+      - TFracHFtoD+      - TFindLiteralIntPattern+      - TFindLiteralIntCase+      - TFindLiteralIntCase2+      - TFindLiteralDoReturn+      - TFindLiteralDoLet+      - TFindLiteralList+      - TExpectNoBinaryFormat+      - TExpectBinaryFormat+      - TExpectNoHexFloatFormat+      - TExpectHexFloatFormat+      - -Wall
+ plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE NumDecimals #-}+module TIntDtoND where++convertMe :: Integer+convertMe = 125.345e3
+ plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.CabalFmt where++import           Control.Lens+import           Control.Monad.Except        (throwError)+import           Control.Monad.IO.Class+import qualified Data.Text                   as T+import           Development.IDE             hiding (pluginHandlers)+import           Ide.Plugin.Error            (PluginError (PluginInternalError, PluginInvalidParams))+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens  as L+import           Language.LSP.Protocol.Types+import           Prelude                     hiding (log)+import           System.Directory+import           System.Exit+import           System.FilePath+import           System.Process.ListLike+import qualified System.Process.Text         as Process++data Log+  = LogProcessInvocationFailure Int+  | LogReadCreateProcessInfo T.Text [String]+  | LogInvalidInvocationInfo+  | LogCabalFmtNotFound+  deriving (Show)++instance Pretty Log where+  pretty = \case+    LogProcessInvocationFailure exitCode -> "Invocation of cabal-fmt failed with code" <+> pretty exitCode+    LogReadCreateProcessInfo stdErrorOut args ->+      vcat $+        ["Invocation of cabal-fmt with arguments" <+> pretty args]+          ++ ["failed with standard error:" <+> pretty stdErrorOut | not (T.null stdErrorOut)]+    LogInvalidInvocationInfo -> "Invocation of cabal-fmt with range was called but is not supported."+    LogCabalFmtNotFound -> "Couldn't find executable 'cabal-fmt'"++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  (defaultCabalPluginDescriptor plId "Provides formatting of cabal files with cabal-fmt")+    { pluginHandlers = mkFormattingHandlers (provider recorder)+    }++-- | Formatter provider of cabal fmt.+-- Formats the given source in either a given Range or the whole Document.+-- If the provider fails an error is returned that can be displayed to the user.+provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState+provider recorder _ _ (FormatRange _) _ _ _ = do+  logWith recorder Info LogInvalidInvocationInfo+  throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt."+provider recorder _ide _ FormatText contents nfp opts = do+  let cabalFmtArgs = [ "--indent", show tabularSize]+  x <- liftIO $ findExecutable "cabal-fmt"+  case x of+    Just _ -> do+      (exitCode, out, err) <-+        liftIO $ Process.readCreateProcessWithExitCode+          ( proc "cabal-fmt" cabalFmtArgs+          )+            { cwd = Just $ takeDirectory fp+            }+          contents+      log Debug $ LogReadCreateProcessInfo err cabalFmtArgs+      case exitCode of+        ExitFailure code -> do+          log Error $ LogProcessInvocationFailure code+          throwError (PluginInternalError "Failed to invoke cabal-fmt")+        ExitSuccess -> do+          let fmtDiff = makeDiffTextEdit contents out+          pure $ InL fmtDiff+    Nothing -> do+      log Error LogCabalFmtNotFound+      throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.")+  where+    fp = fromNormalizedFilePath nfp+    tabularSize = opts ^. L.tabSize+    log = logWith recorder
+ plugins/hls-cabal-fmt-plugin/test/Main.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+module Main+  ( main+  ) where++import qualified Ide.Plugin.CabalFmt as CabalFmt+import           System.Directory    (findExecutable)+import           System.FilePath+import           Test.Hls++data CabalFmtFound = Found | NotFound++isTestIsolated :: Bool+#if isolateTests+isTestIsolated = True+#else+isTestIsolated = False+#endif++isCabalFmtFound :: IO CabalFmtFound+isCabalFmtFound = case isTestIsolated of+  True -> pure Found+  False-> do+    cabalFmt <- findExecutable "cabal-fmt"+    pure $ maybe NotFound (const Found) cabalFmt++main :: IO ()+main = do+  foundCabalFmt <- isCabalFmtFound+  defaultTestRunner (tests foundCabalFmt)++cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log+cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt"++tests :: CabalFmtFound -> TestTree+tests found = testGroup "cabal-fmt"+  [ knownBrokenOnWindows "Eats newlines between comments" $+    cabalFmtGolden found "formats a simple document" "simple_testdata" "formatted_document" $ \doc -> do+      formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing)++  , expectFailBecause "cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking issue: https://github.com/phadej/cabal-fmt/pull/82" $+    cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do+      formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing)++  , cabalFmtGolden found "formats a document with lib information" "lib_testdata" "formatted_document" $ \doc -> do+      formatDoc doc (FormattingOptions 10 True Nothing Nothing Nothing)+  ]++cabalFmtGolden :: CabalFmtFound -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+cabalFmtGolden NotFound title _ _ _ =+  testCase title $+    assertFailure $  "Couldn't find cabal-fmt on PATH or this is not an isolated run. "+                  <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally."+cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter def cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act+  where+    conf = def++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-cabal-fmt-plugin" </> "test" </> "testdata"
+ plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.cabal view
@@ -0,0 +1,12 @@+cabal-version:      2.4+name:               testdata+version:            0.1.0.0+author:             Banana+extra-source-files: CHANGELOG.md++library+    -- cabal-fmt: expand src+    exposed-modules:  MyLib+    build-depends:    base ^>=4.14.1.0+    hs-source-dirs:   src+    default-language: Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal view
@@ -0,0 +1,15 @@+cabal-version:      2.4+name:               testdata+version:            0.1.0.0+author:             Banana+extra-source-files: CHANGELOG.md++library+  -- cabal-fmt: expand src+  exposed-modules:+    MyLib+    MyOtherLib++  build-depends:    base ^>=4.14.1.0+  hs-source-dirs:   src+  default-language: Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.cabal view
@@ -0,0 +1,19 @@+cabal-version:      2.4+name:               testdata+version:                           0.1.0.0+author:        Gregg+extra-source-files: CHANGELOG.md++library+    exposed-modules:  MyLib+    build-depends:    base   ^>=4.14.1.0+    hs-source-dirs:   src+    default-language: Haskell2010++executable testdata+    main-is:          Main.hs+    build-depends:+        base                ^>=4.14.1.0,testdata+    hs-source-dirs:   app+    default-language:+        Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.formatted_document.cabal view
@@ -0,0 +1,20 @@+cabal-version:      2.4+name:               testdata+version:            0.1.0.0+author:             Gregg+extra-source-files: CHANGELOG.md++library+          exposed-modules:  MyLib+          build-depends:    base ^>=4.14.1.0+          hs-source-dirs:   src+          default-language: Haskell2010++executable testdata+          main-is:          Main.hs+          build-depends:+                    , base      ^>=4.14.1.0+                    , testdata+          +          hs-source-dirs:   app+          default-language: Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.cabal view
@@ -0,0 +1,36 @@+cabal-version:      2.4+name:               testdata+version:            0.1.0.0++-- A short (one-line) description of the package.+-- synopsis:++-- A longer description of the package.+-- description:++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+-- license:+author:             Milky++-- An email address to which users can send suggestions, bug reports, and patches.+-- maintainer:++-- A copyright notice.+-- copyright:+-- category:+extra-source-files: CHANGELOG.md++executable testdata+    main-is:          Main.hs++    -- Modules included in this executable, other than Main.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:+    build-depends:    base ^>=4.14.1.0+    hs-source-dirs:   app+    default-language: Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.formatted_document.cabal view
@@ -0,0 +1,36 @@+cabal-version:      2.4+name:               testdata+version:            0.1.0.0++-- A short (one-line) description of the package.+-- synopsis:++-- A longer description of the package.+-- description:++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+-- license:+author:             Milky++-- An email address to which users can send suggestions, bug reports, and patches.+-- maintainer:++-- A copyright notice.+-- copyright:+-- category:+extra-source-files: CHANGELOG.md++executable testdata+  main-is:          Main.hs++  -- Modules included in this executable, other than Main.+  -- other-modules:++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:+  build-depends:    base ^>=4.14.1.0+  hs-source-dirs:   app+  default-language: Haskell2010
+ plugins/hls-cabal-fmt-plugin/test/testdata/src/MyLib.hs view
@@ -0,0 +1,4 @@+module MyLib (someFunc) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ plugins/hls-cabal-fmt-plugin/test/testdata/src/MyOtherLib.hs view
@@ -0,0 +1,3 @@+module MyOtherLib where++bar = 2
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}++module Ide.Plugin.Cabal (descriptor, Log (..)) where++import           Control.Concurrent.STM+import           Control.Concurrent.Strict+import           Control.DeepSeq+import           Control.Lens                                ((^.))+import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class                   (lift)+import           Control.Monad.Trans.Maybe                   (runMaybeT)+import qualified Data.ByteString                             as BS+import           Data.Hashable+import           Data.HashMap.Strict                         (HashMap)+import qualified Data.HashMap.Strict                         as HashMap+import qualified Data.List.NonEmpty                          as NE+import qualified Data.Text.Encoding                          as Encoding+import           Data.Typeable+import           Development.IDE                             as D+import           Development.IDE.Core.Shake                  (restartShakeSession)+import qualified Development.IDE.Core.Shake                  as Shake+import           Development.IDE.Graph                       (alwaysRerun)+import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide+import qualified Development.IDE.Plugin.Completions.Types    as Ghcide+import           GHC.Generics+import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes+import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions+import qualified Ide.Plugin.Cabal.Completion.Types           as Types+import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics+import qualified Ide.Plugin.Cabal.LicenseSuggest             as LicenseSuggest+import qualified Ide.Plugin.Cabal.Parse                      as Parse+import           Ide.Types+import qualified Language.LSP.Protocol.Lens                  as JL+import qualified Language.LSP.Protocol.Message               as LSP+import           Language.LSP.Protocol.Types+import           Language.LSP.Server                         (getVirtualFile)+import qualified Language.LSP.VFS                            as VFS++data Log+  = LogModificationTime NormalizedFilePath FileVersion+  | LogShake Shake.Log+  | LogDocOpened Uri+  | LogDocModified Uri+  | LogDocSaved Uri+  | LogDocClosed Uri+  | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus)+  | LogCompletionContext Types.Context Position+  | LogCompletions Types.Log+  deriving (Show)++instance Pretty Log where+  pretty = \case+    LogShake log' -> pretty log'+    LogModificationTime nfp modTime ->+      "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime)+    LogDocOpened uri ->+      "Opened text document:" <+> pretty (getUri uri)+    LogDocModified uri ->+      "Modified text document:" <+> pretty (getUri uri)+    LogDocSaved uri ->+      "Saved text document:" <+> pretty (getUri uri)+    LogDocClosed uri ->+      "Closed text document:" <+> pretty (getUri uri)+    LogFOI files ->+      "Set files of interest to:" <+> viaShow files+    LogCompletionContext context position ->+      "Determined completion context:"+        <+> viaShow context+        <+> "for cursor position:"+        <+> pretty position+    LogCompletions logs -> pretty logs++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  (defaultCabalPluginDescriptor plId "Provides a variety of IDE features in cabal files")+    { pluginRules = cabalRules recorder plId+    , pluginHandlers =+        mconcat+          [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction+          , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder+          ]+    , pluginNotificationHandlers =+        mconcat+          [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $+              \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do+                whenUriFile _uri $ \file -> do+                  log' Debug $ LogDocOpened _uri+                  addFileOfInterest recorder ide file Modified{firstOpen = True}+                  restartCabalShakeSession (shakeExtras ide) vfs file "(opened)"+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $+              \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do+                whenUriFile _uri $ \file -> do+                  log' Debug $ LogDocModified _uri+                  addFileOfInterest recorder ide file Modified{firstOpen = False}+                  restartCabalShakeSession (shakeExtras ide) vfs file "(changed)"+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $+              \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do+                whenUriFile _uri $ \file -> do+                  log' Debug $ LogDocSaved _uri+                  addFileOfInterest recorder ide file OnDisk+                  restartCabalShakeSession (shakeExtras ide) vfs file "(saved)"+          , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $+              \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do+                whenUriFile _uri $ \file -> do+                  log' Debug $ LogDocClosed _uri+                  deleteFileOfInterest recorder ide file+                  restartCabalShakeSession (shakeExtras ide) vfs file "(closed)"+          ]+    , pluginConfigDescriptor = defaultConfigDescriptor+      { configHasDiagnostics = True+      }+    }+ where+  log' = logWith recorder++  whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()+  whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath'++{- | Helper function to restart the shake session, specifically for modifying .cabal files.+No special logic, just group up a bunch of functions you need for the base+Notification Handlers.++To make sure diagnostics are up to date, we need to tell shake that the file was touched and+needs to be re-parsed. That's what we do when we record the dirty key that our parsing+rule depends on.+Then we restart the shake session, so that changes to our virtual files are actually picked up.+-}+restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO ()+restartCabalShakeSession shakeExtras vfs file actionMsg = do+  join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file]+  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) []++-- ----------------------------------------------------------------+-- Plugin Rules+-- ----------------------------------------------------------------++cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+cabalRules recorder plId = do+  -- Make sure we initialise the cabal files-of-interest.+  ofInterestRules recorder+  -- Rule to produce diagnostics for cabal files.+  define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do+    config <- getPluginConfigAction plId+    if not (plcGlobalOn config && plcDiagnosticsOn config)+        then pure ([], Nothing)+        else do+          -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),+          -- we rerun this rule because this rule *depends* on GetModificationTime.+          (t, mCabalSource) <- use_ GetFileContents file+          log' Debug $ LogModificationTime file t+          contents <- case mCabalSource of+            Just sources ->+              pure $ Encoding.encodeUtf8 sources+            Nothing -> do+              liftIO $ BS.readFile $ fromNormalizedFilePath file++          (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents+          let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings+          case pm of+            Left (_cabalVersion, pErrorNE) -> do+              let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE+                  allDiags = errorDiags <> warningDiags+              pure (allDiags, Nothing)+            Right gpd -> do+              pure (warningDiags, Just gpd)++  action $ do+    -- Run the cabal kick. This code always runs when 'shakeRestart' is run.+    -- Must be careful to not impede the performance too much. Crucial to+    -- a snappy IDE experience.+    kick+ where+  log' = logWith recorder++{- | This is the kick function for the cabal plugin.+We run this action, whenever we shake session us run/restarted, which triggers+actions to produce diagnostics for cabal files.++It is paramount that this kick-function can be run quickly, since it is a blocking+function invocation.+-}+kick :: Action ()+kick = do+  files <- HashMap.keys <$> getCabalFilesOfInterestUntracked+  void $ uses Types.GetCabalDiagnostics files++-- ----------------------------------------------------------------+-- Code Actions+-- ----------------------------------------------------------------++licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) =+  pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri)++-- ----------------------------------------------------------------+-- Cabal file of Interest rules and global variable+-- ----------------------------------------------------------------++{- | Cabal files that are currently open in the lsp-client.+Specific actions happen when these files are saved, closed or modified,+such as generating diagnostics, re-parsing, etc...++We need to store the open files to parse them again if we restart the shake session.+Restarting of the shake session happens whenever these files are modified.+-}+newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))++instance Shake.IsIdeGlobal OfInterestCabalVar++data IsCabalFileOfInterest = IsCabalFileOfInterest+  deriving (Eq, Show, Typeable, Generic)+instance Hashable IsCabalFileOfInterest+instance NFData IsCabalFileOfInterest++type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult++data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus+  deriving (Eq, Show, Typeable, Generic)+instance Hashable CabalFileOfInterestResult+instance NFData CabalFileOfInterestResult++{- | The rule that initialises the files of interest state.++Needs to be run on start-up.+-}+ofInterestRules :: Recorder (WithPriority Log) -> Rules ()+ofInterestRules recorder = do+  Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty)+  Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do+    alwaysRerun+    filesOfInterest <- getCabalFilesOfInterestUntracked+    let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest+        fp = summarize foi+        res = (Just fp, Just foi)+    return res+ where+  summarize NotCabalFOI                   = BS.singleton 0+  summarize (IsCabalFOI OnDisk)           = BS.singleton 1+  summarize (IsCabalFOI (Modified False)) = BS.singleton 2+  summarize (IsCabalFOI (Modified True))  = BS.singleton 3++getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)+getCabalFilesOfInterestUntracked = do+  OfInterestCabalVar var <- Shake.getIdeGlobalAction+  liftIO $ readVar var++addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()+addFileOfInterest recorder state f v = do+  OfInterestCabalVar var <- Shake.getIdeGlobalState state+  (prev, files) <- modifyVar var $ \dict -> do+    let (prev, new) = HashMap.alterF (,Just v) f dict+    pure (new, (prev, new))+  when (prev /= Just v) $ do+    join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]+    log' Debug $ LogFOI files+ where+  log' = logWith recorder++deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()+deleteFileOfInterest recorder state f = do+  OfInterestCabalVar var <- Shake.getIdeGlobalState state+  files <- modifyVar' var $ HashMap.delete f+  join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]+  log' Debug $ LogFOI files+ where+  log' = logWith recorder++-- ----------------------------------------------------------------+-- Completion+-- ----------------------------------------------------------------++completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion+completion recorder ide _ complParams = do+  let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument+      position = complParams ^. JL.position+  contents <- lift $ getVirtualFile $ toNormalizedUri uri+  case (contents, uriToFilePath' uri) of+    (Just cnts, Just path) -> do+      let pref = Ghcide.getCompletionPrefix position cnts+      let res = result pref path cnts+      liftIO $ fmap InL res+    _ -> pure . InR $ InR Null+ where+  result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem]+  result prefix fp cnts = do+    runMaybeT context >>= \case+      Nothing -> pure []+      Just ctx -> do+        logWith recorder Debug $ LogCompletionContext ctx pos+        let completer = Completions.contextToCompleter ctx+        let completerData = CompleterTypes.CompleterData+              { getLatestGPD = do+                mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp+                pure $ fmap fst mGPD+              , cabalPrefixInfo = prefInfo+              , stanzaName =+                case fst ctx of+                  Types.Stanza _ name -> name+                  _                   -> Nothing+              }+        completions <- completer completerRecorder completerData+        pure completions+   where+    completerRecorder = cmapWithPrio LogCompletions recorder+    pos = Ghcide.cursorPos prefix+    context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text)+    prefInfo = Completions.getCabalPrefixInfo fp prefix
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE LambdaCase #-}++module Ide.Plugin.Cabal.Completion.Completer.FilePath where++import           Control.Exception                            (evaluate, try)+import           Control.Monad                                (filterM)+import           Control.Monad.Extra                          (concatForM, forM)+import qualified Data.Text                                    as T+import           Distribution.PackageDescription              (GenericPackageDescription)+import           Ide.Logger+import           Ide.Plugin.Cabal.Completion.Completer.Paths+import           Ide.Plugin.Cabal.Completion.Completer.Simple+import           Ide.Plugin.Cabal.Completion.Completer.Types+import           Ide.Plugin.Cabal.Completion.Types+import           System.Directory                             (doesDirectoryExist,+                                                               doesFileExist,+                                                               listDirectory)+import qualified System.FilePath                              as FP+import qualified System.FilePath.Posix                        as Posix+import qualified Text.Fuzzy.Parallel                          as Fuzzy++-- | Completer to be used when a file path can be completed for a field.+--  Completes file paths as well as directories.+filePathCompleter :: Completer+filePathCompleter recorder cData = do+  let prefInfo = cabalPrefixInfo cData+      complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo+  filePathCompletions <- listFileCompletions recorder complInfo+  let scored =+        Fuzzy.simpleFilter+          Fuzzy.defChunkSize+          Fuzzy.defMaxResults+          (pathSegment complInfo)+          (map T.pack filePathCompletions)+  forM+    scored+    ( \compl' -> do+        let compl = Fuzzy.original compl'+        fullFilePath <- mkFilePathCompletion complInfo compl+        pure $ mkCompletionItem (completionRange prefInfo) fullFilePath fullFilePath+    )++mainIsCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer+mainIsCompleter extractionFunction recorder cData = do+  mGPD <- getLatestGPD cData+  case mGPD of+    Just gpd -> do+      let srcDirs = extractionFunction sName gpd+      concatForM srcDirs+        (\dir' -> do+        let dir = FP.normalise dir'+        let pathInfo = pathCompletionInfoFromCabalPrefixInfo dir prefInfo+        completions <- listFileCompletions recorder pathInfo+        let scored = Fuzzy.simpleFilter+              Fuzzy.defChunkSize+              Fuzzy.defMaxResults+              (pathSegment pathInfo)+              (map T.pack completions)+        forM+          scored+          ( \compl' -> do+              let compl = Fuzzy.original compl'+              fullFilePath <- mkFilePathCompletion pathInfo compl+              pure $ mkCompletionItem (completionRange prefInfo) fullFilePath fullFilePath+          )+        )+    Nothing -> do+      logWith recorder Debug LogUseWithStaleFastNoResult+      pure []+  where+    sName = stanzaName cData+    prefInfo = cabalPrefixInfo cData+++-- | Completer to be used when a directory can be completed for the field.+--  Only completes directories.+directoryCompleter :: Completer+directoryCompleter recorder cData = do+  let prefInfo = cabalPrefixInfo cData+      complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo+  directoryCompletions <- listDirectoryCompletions recorder complInfo+  let scored =+        Fuzzy.simpleFilter+          Fuzzy.defChunkSize+          Fuzzy.defMaxResults+          (pathSegment complInfo)+          (map T.pack directoryCompletions)+  forM+    scored+    ( \compl' -> do+        let compl = Fuzzy.original compl'+        let fullDirPath = mkPathCompletionDir complInfo compl+        pure $ mkCompletionItem (completionRange prefInfo) fullDirPath fullDirPath+    )++{- Note [Using correct file path separators]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Since cabal files only allow for posix style file paths+  we need to be careful to use the correct path separators+  whenever we work with file paths in cabal files.++  Thus we are using two different kinds of imports.+  We use "FP" for platform-compatible file paths with which+  we can query files independently of the platform.+  We use "Posix" for the posix syntax paths which need to+  be used for file path completions to be written to the cabal file.+-}++-- | Takes a PathCompletionInfo and returns the list of files and directories+--  in the directory which match the path completion info in posix style.+--+--  The directories end with a posix trailing path separator.+--  Since this is used for completions to be written to the cabal file,+--  we use posix separators here.+--  See Note [Using correct file path separators].+listFileCompletions :: Recorder (WithPriority Log) -> PathCompletionInfo -> IO [FilePath]+listFileCompletions recorder complInfo = do+  let complDir = mkCompletionDirectory complInfo+  try (evaluate =<< listDirectory complDir) >>= \case+    Right dirs -> do+      forM dirs $ \d -> do+        isDir <- doesDirectoryExist $ mkDirFromCWD complInfo d+        pure $ if isDir then Posix.addTrailingPathSeparator d else d+    Left (err :: IOError) -> do+      logWith recorder Warning $ LogFilePathCompleterIOError complDir err+      pure []++-- | Returns a list of all (and only) directories in the+--  directory described by path completion info.+listDirectoryCompletions :: Recorder (WithPriority Log) -> PathCompletionInfo -> IO [FilePath]+listDirectoryCompletions recorder complInfo = do+  filepaths <- listFileCompletions recorder complInfo+  filterM (doesDirectoryExist . mkDirFromCWD complInfo) filepaths++-- | Returns the directory where files and directories can be queried from+--  for the passed PathCompletionInfo.+--+--  Returns the full path to the directory pointed to by the path prefix+--  by combining it with the working directory.+--+--  Since this is used for querying paths we use platform+--  compatible separators here.+--  See Note [Using correct file path separators].+mkCompletionDirectory :: PathCompletionInfo -> FilePath+mkCompletionDirectory complInfo =+  FP.addTrailingPathSeparator $+    workingDirectory complInfo FP.</> (FP.normalise $ queryDirectory complInfo)++-- | Returns the full path for the given path segment+--  by combining the working directory with the path prefix+--  and the path segment.+--+--  Since this is used for querying paths we use platform+--  compatible separators here.+--  See Note [Using correct file path separators].+mkDirFromCWD :: PathCompletionInfo -> FilePath -> FilePath+mkDirFromCWD complInfo fp =+  FP.addTrailingPathSeparator $+    mkCompletionDirectory complInfo FP.</> FP.normalise fp++-- | Takes a PathCompletionInfo and a directory and+--  returns the complete cabal path to be written on completion action+--  by combining the previously written path prefix and the completed+--  path segment.+--+--  Since this is used for completions we use posix separators here.+--  See Note [Using correct file path separators].+mkPathCompletionDir :: PathCompletionInfo -> T.Text -> T.Text+mkPathCompletionDir complInfo completion =+  T.pack $+    queryDirectory complInfo Posix.</> T.unpack completion++-- | Takes a PathCompletionInfo and a completed path segment and+--  generates the whole filepath to be completed.+--+--  The returned text combines the completion with a relative path+--  generated from a possible previously written path prefix and+--  is relative to the cabal file location.+--+--  If the completion results in a filepath, we know this is a+--  completed path and can thus apply wrapping of apostrophes if needed.+mkFilePathCompletion :: PathCompletionInfo -> T.Text -> IO T.Text+mkFilePathCompletion complInfo completion = do+  let combinedPath = mkPathCompletionDir complInfo completion+  isFilePath <- doesFileExist $ T.unpack combinedPath+  let completedPath = if isFilePath then applyStringNotation (isStringNotationPath complInfo) combinedPath else combinedPath+  pure completedPath
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Cabal.Completion.Completer.Module where++import           Control.Monad                                  (filterM)+import           Control.Monad.Extra                            (concatForM,+                                                                 forM)+import           Data.List                                      (stripPrefix)+import           Data.Maybe                                     (fromMaybe)+import qualified Data.Text                                      as T+import           Distribution.PackageDescription                (GenericPackageDescription)+import           Ide.Logger                                     (Priority (..),+                                                                 Recorder,+                                                                 WithPriority,+                                                                 logWith)+import           Ide.Plugin.Cabal.Completion.Completer.FilePath (listFileCompletions,+                                                                 mkCompletionDirectory)+import           Ide.Plugin.Cabal.Completion.Completer.Paths+import           Ide.Plugin.Cabal.Completion.Completer.Simple+import           Ide.Plugin.Cabal.Completion.Completer.Types+import           Ide.Plugin.Cabal.Completion.Types+import           System.Directory                               (doesFileExist)+import qualified System.FilePath                                as FP+import qualified Text.Fuzzy.Parallel                            as Fuzzy++-- | Completer to be used when module paths can be completed for the field.+--+-- Takes an extraction function which extracts the source directories+-- to be used by the completer.+modulesCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer+modulesCompleter extractionFunction recorder cData = do+  mGPD <- getLatestGPD cData+  case mGPD of+    Just gpd -> do+      let sourceDirs = extractionFunction sName gpd+      filePathCompletions <-+        filePathsForExposedModules recorder sourceDirs prefInfo+      pure $ map (\compl -> mkSimpleCompletionItem (completionRange prefInfo) compl) filePathCompletions+    Nothing -> do+      logWith recorder Debug LogUseWithStaleFastNoResult+      pure []+  where+    sName = stanzaName cData+    prefInfo = cabalPrefixInfo cData++-- | Takes a list of source directories and returns a list of path completions+--  relative to any of the passed source directories which fit the passed prefix info.+filePathsForExposedModules :: Recorder (WithPriority Log) -> [FilePath] -> CabalPrefixInfo -> IO [T.Text]+filePathsForExposedModules recorder srcDirs prefInfo = do+  concatForM+    srcDirs+    ( \dir' -> do+        let dir = FP.normalise dir'+            pathInfo = pathCompletionInfoFromCabalPrefixInfo dir modPrefInfo+        completions <- listFileCompletions recorder pathInfo+        validExposedCompletions <- filterM (isValidExposedModulePath pathInfo) completions+        let toMatch = pathSegment pathInfo+            scored = Fuzzy.simpleFilter+              Fuzzy.defChunkSize+              Fuzzy.defMaxResults+              toMatch+              (map T.pack validExposedCompletions)+        forM+          scored+          ( \compl' -> do+              let compl = Fuzzy.original compl'+              fullFilePath <- mkExposedModulePathCompletion pathInfo $ T.unpack compl+              pure fullFilePath+          )+    )+  where+    prefix =+      T.pack $ exposedModulePathToFp $+        completionPrefix prefInfo+    -- build completion info relative to the source dir,+    -- we overwrite the prefix written in the cabal file with its translation+    -- to filepath syntax, since it is in exposed module syntax+    modPrefInfo = prefInfo{completionPrefix=prefix}++    --    Takes a PathCompletionInfo and a path segment and checks whether+    --    the path segment can be completed for an exposed module.+    --+    --    This is the case if the segment represents either a directory or a Haskell file.+    isValidExposedModulePath :: PathCompletionInfo -> FilePath -> IO Bool+    isValidExposedModulePath pInfo path = do+      let dir = mkCompletionDirectory pInfo+      fileExists <- doesFileExist (dir FP.</> path)+      pure $ not fileExists || FP.takeExtension path `elem` [".hs", ".lhs"]++-- | Takes a pathCompletionInfo and a path segment and generates the whole+--  filepath to be written on completion including a possibly already written prefix;+--  using the cabal syntax for exposed modules.+--+--  Examples:+--  When the partial directory path `Dir.Dir2.` is stored in the PathCompletionInfo+--  and the completed file `HaskellFile.hs` is passed along with that PathCompletionInfo,+--  the result would be `Dir1.Dir2.HaskellFile`+--+--  When the partial directory path `Dir.` is stored in the PathCompletionInfo+--  and the completed directory `Dir2` is passed along with that PathCompletionInfo,+--  the result would be `Dir1.Dir2.`+mkExposedModulePathCompletion :: PathCompletionInfo -> FilePath -> IO T.Text+mkExposedModulePathCompletion complInfo completion = do+  let combinedPath = queryDirectory complInfo FP.</> completion+  isFilePath <- doesFileExist (workingDirectory complInfo FP.</> combinedPath)+  let addTrailingDot modPath = if isFilePath then modPath else modPath <> "."+  let exposedPath = FP.makeRelative "." combinedPath+  pure $ addTrailingDot $ fpToExposedModulePath "" exposedPath++-- | Takes a source directory path and a module path and returns+--  the module path relative to the source directory+--  in exposed module syntax where the separators are '.'+--  and the file ending is removed.+--+-- Synopsis: @'fpToExposedModulePath' sourceDir modPath@.+fpToExposedModulePath :: FilePath -> FilePath -> T.Text+fpToExposedModulePath sourceDir modPath =+  T.intercalate "." $ fmap T.pack $ FP.splitDirectories $ FP.dropExtension fp+  where+    fp = fromMaybe modPath $ stripPrefix sourceDir modPath++-- | Takes a path in the exposed module syntax and translates it to a platform-compatible file path.+exposedModulePathToFp :: T.Text -> FilePath+exposedModulePathToFp fp = T.unpack $ T.replace "." (T.singleton FP.pathSeparator) fp
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs view
@@ -0,0 +1,118 @@+module Ide.Plugin.Cabal.Completion.Completer.Paths where++import qualified Data.List                         as List+import qualified Data.Text                         as T+import           Distribution.PackageDescription   (Benchmark (..),+                                                    BuildInfo (..),+                                                    CondTree (condTreeData),+                                                    Executable (..),+                                                    GenericPackageDescription (..),+                                                    Library (..),+                                                    UnqualComponentName,+                                                    mkUnqualComponentName,+                                                    testBuildInfo)+import           Distribution.Utils.Path           (getSymbolicPath)+import           Ide.Plugin.Cabal.Completion.Types+import qualified System.FilePath                   as FP+import qualified System.FilePath.Posix             as Posix+++{- | Information used to query and build path completions.++  Note that pathSegment  combined with queryDirectory  results in+  the original prefix.++  Example:+  When given the written prefix, @dir1\/dir2\/fi@, the+  resulting PathCompletionInfo would be:++  @+    pathSegment = "fi"+    queryDirectory  = "dir1\/dir2\/fi"+    ...+  @+-}+data PathCompletionInfo = PathCompletionInfo+  { pathSegment          :: T.Text,+    -- ^ Partly written segment of the next part of the path.+    queryDirectory       :: FilePath,+    -- ^ Written part of path, in posix format.+    workingDirectory     :: FilePath,+    -- ^ Directory relative to which relative paths are interpreted, platform dependent.+    isStringNotationPath :: Maybe Apostrophe+    -- ^ Did the completion happen in the context of a string notation,+    -- if yes, contains the state of the string notation.+  }+  deriving (Eq, Show)++{- | Takes an optional source subdirectory and a prefix info+  and creates a path completion info accordingly.++  The source directory represents some subdirectory of the working directory such as a+  path from the field @hs-source-dirs@.++  If the source subdirectory is empty, then the working directory is simply set to+  the currently handled cabal file's directory.+-}+pathCompletionInfoFromCabalPrefixInfo :: FilePath -> CabalPrefixInfo -> PathCompletionInfo+pathCompletionInfoFromCabalPrefixInfo srcDir prefInfo =+  PathCompletionInfo+    { pathSegment = T.pack pathSegment',+      queryDirectory = queryDirectory',+      workingDirectory = completionWorkingDir prefInfo FP.</> srcDir,+      isStringNotationPath = isStringNotation prefInfo+    }+  where+    prefix = T.unpack $ completionPrefix prefInfo+    (queryDirectory', pathSegment') = Posix.splitFileName prefix++-- | Extracts the source directories of the library stanza.+sourceDirsExtractionLibrary :: Maybe StanzaName -> GenericPackageDescription -> [FilePath]+sourceDirsExtractionLibrary Nothing gpd =+  -- we use condLibrary to get the information contained in the library stanza+  -- since the library in PackageDescription is not populated by us+  case libM of+    Just lib -> do+      map getSymbolicPath $ hsSourceDirs $ libBuildInfo $ condTreeData lib+    Nothing -> []+  where+    libM = condLibrary gpd+sourceDirsExtractionLibrary name gpd = extractRelativeDirsFromStanza name gpd condSubLibraries libBuildInfo++-- | Extracts the source directories of the executable stanza with the given name.+sourceDirsExtractionExecutable :: Maybe StanzaName -> GenericPackageDescription -> [FilePath]+sourceDirsExtractionExecutable name gpd = extractRelativeDirsFromStanza name gpd condExecutables buildInfo++-- | Extracts the source directories of the test suite stanza with the given name.+sourceDirsExtractionTestSuite :: Maybe StanzaName -> GenericPackageDescription -> [FilePath]+sourceDirsExtractionTestSuite name gpd = extractRelativeDirsFromStanza name gpd condTestSuites testBuildInfo++-- | Extracts the source directories of benchmark stanza with the given name.+sourceDirsExtractionBenchmark :: Maybe StanzaName -> GenericPackageDescription -> [FilePath]+sourceDirsExtractionBenchmark name gpd = extractRelativeDirsFromStanza name gpd condBenchmarks benchmarkBuildInfo++{- | Takes a possible stanza name, a GenericPackageDescription,+  a function to access the stanza information we are interested in+  and a function to access the build info from the specific stanza.++  Returns a list of relative source directory paths specified for the extracted stanza.+-}+extractRelativeDirsFromStanza ::+  Maybe StanzaName ->+  GenericPackageDescription ->+  (GenericPackageDescription -> [(UnqualComponentName, CondTree b c a)]) ->+  (a -> BuildInfo) ->+  [FilePath]+extractRelativeDirsFromStanza Nothing _ _ _ = []+extractRelativeDirsFromStanza (Just name) gpd getStanza getBuildInfo+  | Just stanza <- stanzaM = map getSymbolicPath $ hsSourceDirs $ getBuildInfo stanza+  | otherwise = []+  where+    stanzaM = fmap (condTreeData . snd) res+    allStanzasM = getStanza gpd+    res =+      List.find+        ( \(n, _) ->+            n == mkUnqualComponentName (T.unpack name)+        )+        allStanzasM
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Cabal.Completion.Completer.Simple where++import           Control.Lens                                ((?~))+import           Data.Function                               ((&))+import qualified Data.List                                   as List+import           Data.Map                                    (Map)+import qualified Data.Map                                    as Map+import           Data.Maybe                                  (fromMaybe)+import           Data.Ord                                    (Down (Down))+import qualified Data.Text                                   as T+import           Ide.Logger                                  (Priority (..),+                                                              logWith)+import           Ide.Plugin.Cabal.Completion.Completer.Types+import           Ide.Plugin.Cabal.Completion.Types           (CabalPrefixInfo (..),+                                                              Log)+import qualified Language.LSP.Protocol.Lens                  as JL+import qualified Language.LSP.Protocol.Types                 as Compls (CompletionItem (..))+import qualified Language.LSP.Protocol.Types                 as LSP+import qualified Text.Fuzzy.Parallel                         as Fuzzy++-- | Completer to be used when no completion suggestions+--  are implemented for the field+noopCompleter :: Completer+noopCompleter _ _ = pure []++-- | Completer to be used when no completion suggestions+--  are implemented for the field and a log message should be emitted.+errorNoopCompleter :: Log -> Completer+errorNoopCompleter l recorder _ = do+  logWith recorder Warning l+  pure []++-- | Completer to be used when a simple set of values+--  can be completed for a field.+constantCompleter :: [T.Text] -> Completer+constantCompleter completions _ cData = do+  let prefInfo = cabalPrefixInfo cData+      scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) completions+      range = completionRange prefInfo+  pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored++-- | Completer to be used for the field @name:@ value.+--+-- This is almost always the name of the cabal file. However,+-- it is not forbidden by the specification to have a different name,+-- it is just forbidden on hackage.+nameCompleter :: Completer+nameCompleter _ cData = do+  let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) [completionFileName prefInfo]+      prefInfo = cabalPrefixInfo cData+      range = completionRange prefInfo+  pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored++-- | Completer to be used when a set of values with priority weights+-- attached to some values are to be completed for a field.+--+--  The higher the weight, the higher the priority to show+--  the value in the completion suggestion.+--+--  If the value does not occur in the weighted map its weight is defaulted to zero.+weightedConstantCompleter :: [T.Text] -> Map T.Text Double -> Completer+weightedConstantCompleter completions weights _ cData = do+  let scored =+        if perfectScore > 0+          then+            fmap Fuzzy.original $+              Fuzzy.simpleFilter' Fuzzy.defChunkSize Fuzzy.defMaxResults prefix completions customMatch+          else topTenByWeight+      range = completionRange prefInfo+  pure $ map (mkSimpleCompletionItem range) scored+  where+    prefInfo = cabalPrefixInfo cData+    prefix = completionPrefix prefInfo+    -- The perfect score is the score of the word matched with itself+    -- this should never return Nothing since we match the word with itself+    perfectScore = fromMaybe (error "match is broken") $ Fuzzy.match prefix prefix+    -- \| Since the best score is cut off at the perfect score, we use a custom match+    -- which allows for the score to be larger than the perfect score.+    --+    -- This is necessary since the weight is multiplied with the originally matched+    -- score and thus the calculated score may be larger than the perfect score.+    customMatch :: (T.Text -> T.Text -> Maybe Int)+    customMatch toSearch searchSpace = do+      matched <- Fuzzy.match toSearch searchSpace+      let weight = fromMaybe 0 $ Map.lookup searchSpace weights+      let score =+            min+              perfectScore+              (round (fromIntegral matched * (1 + weight)))+      pure score+    -- \| Sorts the list in descending order based on the map of weights and then+    -- returns the top ten items in the list+    topTenByWeight :: [T.Text]+    topTenByWeight = take 10 $ map fst $ List.sortOn (Down . snd) $ Map.assocs weights++-- | Creates a CompletionItem with the given text as the label+-- where the completion item kind is keyword.+mkDefaultCompletionItem :: T.Text -> LSP.CompletionItem+mkDefaultCompletionItem label =+  LSP.CompletionItem+    { Compls._label = label,+      Compls._labelDetails = Nothing,+      Compls._kind = Just LSP.CompletionItemKind_Keyword,+      Compls._tags = Nothing,+      Compls._detail = Nothing,+      Compls._documentation = Nothing,+      Compls._deprecated = Nothing,+      Compls._preselect = Nothing,+      Compls._sortText = Nothing,+      Compls._filterText = Nothing,+      Compls._insertText = Nothing,+      Compls._insertTextFormat = Nothing,+      Compls._insertTextMode = Nothing,+      Compls._textEdit = Nothing,+      Compls._textEditText = Nothing,+      Compls._additionalTextEdits = Nothing,+      Compls._commitCharacters = Nothing,+      Compls._command = Nothing,+      Compls._data_ = Nothing+    }++-- | Returns a CompletionItem with the given starting position+--  and text to be inserted, where the displayed text is the same as the+--  inserted text.+mkSimpleCompletionItem :: LSP.Range -> T.Text -> LSP.CompletionItem+mkSimpleCompletionItem range txt =+  mkDefaultCompletionItem txt+    & JL.textEdit ?~ LSP.InL (LSP.TextEdit range txt)++-- | Returns a completionItem with the given starting position,+--  text to be inserted and text to be displayed in the completion suggestion.+mkCompletionItem :: LSP.Range -> T.Text -> T.Text -> LSP.CompletionItem+mkCompletionItem range insertTxt displayTxt =+  mkDefaultCompletionItem displayTxt+    & JL.textEdit ?~ LSP.InL (LSP.TextEdit range insertTxt)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Cabal.Completion.Completer.Snippet where++import           Control.Lens                                 ((?~))+import           Control.Monad.Extra                          (mapMaybeM)+import           Data.Function                                ((&))+import           Data.Map                                     (Map)+import qualified Data.Map                                     as Map+import qualified Data.Text                                    as T+import           Ide.Logger                                   (Priority (..),+                                                               logWith)+import           Ide.Plugin.Cabal.Completion.Completer.Simple+import           Ide.Plugin.Cabal.Completion.Completer.Types+import           Ide.Plugin.Cabal.Completion.Types+import qualified Language.LSP.Protocol.Lens                   as JL+import qualified Language.LSP.Protocol.Types                  as LSP+import qualified Text.Fuzzy.Parallel                          as Fuzzy++-- | Maps snippet triggerwords with their completers+snippetCompleter :: Completer+snippetCompleter recorder cData = do+  let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) $ Map.keys snippets+  mapMaybeM+    ( \compl -> do+        let matched = Fuzzy.original compl+        let completion' = Map.lookup matched snippets+        case completion' of+          Nothing -> do+            logWith recorder Warning $ LogMapLookUpOfKnownKeyFailed matched+            pure Nothing+          Just completion ->+            pure $ Just $ mkSnippetCompletion completion matched+    )+    scored+  where+    snippets = snippetMap prefInfo+    prefInfo = cabalPrefixInfo cData+    mkSnippetCompletion :: T.Text -> T.Text -> LSP.CompletionItem+    mkSnippetCompletion insertText toDisplay =+      mkDefaultCompletionItem toDisplay+        & JL.kind ?~ LSP.CompletionItemKind_Snippet+        & JL.insertText ?~ insertText+        & JL.insertTextFormat ?~ LSP.InsertTextFormat_Snippet++type TriggerWord = T.Text++snippetMap :: CabalPrefixInfo -> Map TriggerWord T.Text+snippetMap prefInfo =+  fmap T.unlines $+    Map.fromList+      [ ( "library-snippet",+          [ "library",+            "  hs-source-dirs: $1",+            "  exposed-modules: $2",+            "  build-depends: base",+            "  default-language: Haskell2010"+          ]+        ),+        ( "recommended-fields",+          [ "cabal-version: $1",+            "name: " <> completionFileName prefInfo,+            "version: 0.1.0.0",+            "maintainer: $4",+            "category: $5",+            "synopsis: $6",+            "license: $7",+            "build-type: Simple"+          ]+        ),+        ( "executable-snippet",+          [ "executable $1",+            "  main-is: ${2:Main.hs}",+            "  build-depends: base"+          ]+        ),+        ( "benchmark-snippet",+          [ "benchmark $1",+            "  type: exitcode-stdio-1.0",+            "  main-is: ${3:Main.hs}",+            "  build-depends: base"+          ]+        ),+        ( "testsuite-snippet",+          [ "test-suite $1",+            "  type: exitcode-stdio-1.0",+            "  main-is: ${3:Main.hs}",+            "  build-depends: base"+          ]+        ),+        ( "common-warnings",+          [ "common warnings",+            "  ghc-options: -Wall"+          ]+        ),+        ( "source-repo-github-snippet",+          [ "source-repository head",+            "  type: git",+            "  location: git://github.com/$2"+          ]+        ),+        ( "source-repo-git-snippet",+          [ "source-repository head",+            "  type: git",+            "  location: $1"+          ]+        )+      ]
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}++module Ide.Plugin.Cabal.Completion.Completer.Types where++import           Development.IDE                   as D+import           Distribution.PackageDescription   (GenericPackageDescription)+import           Ide.Plugin.Cabal.Completion.Types+import           Language.LSP.Protocol.Types       (CompletionItem)++-- | Takes information needed to build possible completion items+-- and returns the list of possible completion items+type Completer = Recorder (WithPriority Log) -> CompleterData -> IO [CompletionItem]++-- | Contains information to be used by completers.+data CompleterData = CompleterData+  { -- | Access to the latest available generic package description for the handled cabal file,+    -- relevant for some completion actions which require the file's meta information+    -- such as the module completers which require access to source directories+    getLatestGPD    :: IO (Maybe GenericPackageDescription),+    -- | Prefix info to be used for constructing completion items+    cabalPrefixInfo :: CabalPrefixInfo,+    -- | The name of the stanza in which the completer is applied+    stanzaName      :: Maybe StanzaName+  }
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Cabal.Completion.Completions (contextToCompleter, getContext, getCabalPrefixInfo) where++import           Control.Lens                                  ((^.))+import           Control.Monad.IO.Class                        (MonadIO)+import           Control.Monad.Trans.Maybe+import           Data.Foldable                                 (asum)+import qualified Data.List                                     as List+import           Data.Map                                      (Map)+import qualified Data.Map                                      as Map+import qualified Data.Text                                     as T+import qualified Data.Text.Utf16.Lines                         as Rope (Position (..))+import           Data.Text.Utf16.Rope.Mixed                    (Rope)+import qualified Data.Text.Utf16.Rope.Mixed                    as Rope+import           Development.IDE                               as D+import qualified Development.IDE.Plugin.Completions.Types      as Ghcide+import           Ide.Plugin.Cabal.Completion.Completer.Simple+import           Ide.Plugin.Cabal.Completion.Completer.Snippet+import           Ide.Plugin.Cabal.Completion.Completer.Types   (Completer)+import           Ide.Plugin.Cabal.Completion.Data+import           Ide.Plugin.Cabal.Completion.Types+import qualified Language.LSP.Protocol.Lens                    as JL+import qualified System.FilePath                               as FP+import           System.FilePath                               (takeBaseName)++-- ----------------------------------------------------------------+-- Public API for Completions+-- ----------------------------------------------------------------++-- | Takes information about the completion context within the file+--  and finds the correct completer to be applied.+contextToCompleter :: Context -> Completer+-- if we are in the top level of the cabal file and not in a keyword context,+-- we can write any top level keywords or a stanza declaration+contextToCompleter (TopLevel, None) =+  snippetCompleter+    <> ( constantCompleter $+           Map.keys (cabalVersionKeyword <> cabalKeywords) ++ Map.keys stanzaKeywordMap+       )+-- if we are in a keyword context in the top level,+-- we look up that keyword in the top level context and can complete its possible values+contextToCompleter (TopLevel, KeyWord kw) =+  case Map.lookup kw (cabalVersionKeyword <> cabalKeywords) of+    Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw)+    Just l  -> l+-- if we are in a stanza and not in a keyword context,+-- we can write any of the stanza's keywords or a stanza declaration+contextToCompleter (Stanza s _, None) =+  case Map.lookup s stanzaKeywordMap of+    Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s)+    Just l  -> constantCompleter $ Map.keys l+-- if we are in a stanza's keyword's context we can complete possible values of that keyword+contextToCompleter (Stanza s _, KeyWord kw) =+  case Map.lookup s stanzaKeywordMap of+    Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s)+    Just m -> case Map.lookup kw m of+      Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw)+      Just l  -> l++-- | Takes prefix info about the previously written text+--  and a rope (representing a file), returns the corresponding context.+--+--  Can return Nothing if an error occurs.+--+--  TODO: first line can only have cabal-version: keyword+getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> Rope -> MaybeT m Context+getContext recorder prefInfo ls =+  case prevLinesM of+    Just prevLines -> do+      let lvlContext =+            if completionIndentation prefInfo == 0+              then TopLevel+              else currentLevel prevLines+      case lvlContext of+        TopLevel -> do+          kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines (cabalVersionKeyword <> cabalKeywords)+          pure (TopLevel, kwContext)+        Stanza s n ->+          case Map.lookup s stanzaKeywordMap of+            Nothing -> do+              pure (Stanza s n, None)+            Just m -> do+              kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines m+              pure (Stanza s n, kwContext)+    Nothing -> do+      logWith recorder Warning $ LogFileSplitError pos+      -- basically returns nothing+      fail "Abort computation"+  where+    pos = completionCursorPosition prefInfo+    prevLinesM = splitAtPosition pos ls++-- | Takes information about the current file's file path,+--  and the cursor position in the file; and builds a CabalPrefixInfo+--  with the prefix up to that cursor position.+--  Checks whether a suffix needs to be completed+--  and calculates the range in the document+--  where the completion action should be applied.+getCabalPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo+getCabalPrefixInfo fp prefixInfo =+  CabalPrefixInfo+    { completionPrefix = completionPrefix',+      isStringNotation = mkIsStringNotation separator afterCursorText,+      completionCursorPosition = Ghcide.cursorPos prefixInfo,+      completionRange = Range completionStart completionEnd,+      completionWorkingDir = FP.takeDirectory fp,+      completionFileName = T.pack $ takeBaseName fp+    }+  where+    completionEnd = Ghcide.cursorPos prefixInfo+    completionStart =+      Position+        (_line completionEnd)+        (_character completionEnd - (fromIntegral $ T.length completionPrefix'))+    (beforeCursorText, afterCursorText) = T.splitAt cursorColumn $ Ghcide.fullLine prefixInfo+    completionPrefix' = T.takeWhileEnd (not . (`elem` stopConditionChars)) beforeCursorText+    separator =+      -- if there is an opening apostrophe before the cursor in the line somewhere,+      -- everything after that apostrophe is the completion prefix+      if odd $ T.count "\"" beforeCursorText+        then '\"'+        else ' '+    cursorColumn = fromIntegral $ Ghcide.cursorPos prefixInfo ^. JL.character+    stopConditionChars = separator : [',', ':']++    -- \| Takes the character occurring exactly before,+    --  and the text occurring after the item to be completed and+    --  returns whether the item is already surrounded by apostrophes.+    --+    --  Example: (@|@ indicates the cursor position)+    --+    --  @"./src|@ would call @'\"'@ @""@ and result in Just LeftSide+    --+    --  @"./src|"@ would call @'\"'@ @'\"'@ and result in Just Surrounded+    --+    mkIsStringNotation :: Char -> T.Text -> Maybe Apostrophe+    mkIsStringNotation '\"' restLine+      | Just ('\"', _) <- T.uncons restLine = Just Surrounded+      | otherwise = Just LeftSide+    mkIsStringNotation _ _ = Nothing++-- ----------------------------------------------------------------+-- Implementation Details+-- ----------------------------------------------------------------++-- | Takes prefix info about the previously written text,+--  a list of lines (representing a file) and a map of+--  keywords and returns a keyword context if the+--  previously written keyword matches one in the map.+--+--  From a cursor position, we traverse the cabal file upwards to+--  find the latest written keyword if there is any.+--  Values may be written on subsequent lines,+--  in order to allow for this we take the indentation of the current+--  word to be completed into account to find the correct keyword context.+getKeyWordContext :: CabalPrefixInfo -> [T.Text] -> Map KeyWordName a -> Maybe FieldContext+getKeyWordContext prefInfo ls keywords = do+  case lastNonEmptyLineM of+    Nothing -> Just None+    Just lastLine' -> do+      let (whiteSpaces, lastLine) = T.span (== ' ') lastLine'+      let keywordIndentation = T.length whiteSpaces+      let cursorIndentation = completionIndentation prefInfo+      -- in order to be in a keyword context the cursor needs+      -- to be indented more than the keyword+      if cursorIndentation > keywordIndentation+        then -- if the last thing written was a keyword without a value+        case List.find (`T.isPrefixOf` lastLine) (Map.keys keywords) of+          Nothing -> Just None+          Just kw -> Just $ KeyWord kw+        else Just None+  where+    lastNonEmptyLineM :: Maybe T.Text+    lastNonEmptyLineM = do+      (curLine, rest) <- List.uncons ls+      -- represents the current line while disregarding the+      -- currently written text we want to complete+      let cur = stripPartiallyWritten curLine+      List.find (not . T.null . T.stripEnd) $+        cur : rest++-- | Traverse the given lines (starting before current cursor position+--  up to the start of the file) to find the nearest stanza declaration,+--  if none is found we are in the top level context.+--+--  TODO: this could be merged with getKeyWordContext in order to increase+--  performance by reducing the number of times we have to traverse the cabal file.+currentLevel :: [T.Text] -> StanzaContext+currentLevel [] = TopLevel+currentLevel (cur : xs)+  | Just (s, n) <- stanza = Stanza s n+  | otherwise = currentLevel xs+  where+    stanza = asum $ map checkStanza (Map.keys stanzaKeywordMap)+    checkStanza :: StanzaType -> Maybe (StanzaType, Maybe StanzaName)+    checkStanza t =+      case T.stripPrefix t (T.strip cur) of+        Just n+          | T.null n -> Just (t, Nothing)+          | otherwise -> Just (t, Just $ T.strip n)+        Nothing -> Nothing++-- | Get all lines before the given cursor position in the given file+--  and reverse their order to traverse backwards starting from the given position.+splitAtPosition :: Position -> Rope -> Maybe [T.Text]+splitAtPosition pos ls = do+  split <- splitFile+  pure $ reverse $ Rope.lines $ fst split+  where+    splitFile = Rope.utf16SplitAtPosition ropePos ls+    ropePos =+      Rope.Position+        { Rope.posLine = fromIntegral $ pos ^. JL.line,+          Rope.posColumn = fromIntegral $ pos ^. JL.character+        }++-- | Takes a line of text and removes the last partially+-- written word to be completed.+stripPartiallyWritten :: T.Text -> T.Text+stripPartiallyWritten = T.dropWhileEnd (\y -> (y /= ' ') && (y /= ':'))++-- | Calculates how many spaces the currently completed item is indented.+completionIndentation :: CabalPrefixInfo -> Int+completionIndentation prefInfo = fromIntegral (pos ^. JL.character) - (T.length $ completionPrefix prefInfo)+  where+    pos = completionCursorPosition prefInfo
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Redundant bracket" #-}++module Ide.Plugin.Cabal.Completion.Data where++import           Data.Map                                       (Map)+import qualified Data.Map                                       as Map+import qualified Data.Text                                      as T+import           Development.IDE.GHC.Compat.Core                (flagsForCompletion)+import           Distribution.CabalSpecVersion                  (CabalSpecVersion (CabalSpecV2_2),+                                                                 showCabalSpecVersion)+import           Ide.Plugin.Cabal.Completion.Completer.FilePath+import           Ide.Plugin.Cabal.Completion.Completer.Module+import           Ide.Plugin.Cabal.Completion.Completer.Paths+import           Ide.Plugin.Cabal.Completion.Completer.Simple+import           Ide.Plugin.Cabal.Completion.Completer.Types    (Completer)+import           Ide.Plugin.Cabal.Completion.Types+import           Ide.Plugin.Cabal.LicenseSuggest                (licenseNames)++-- ----------------------------------------------------------------+-- Completion Data+-- ----------------------------------------------------------------++-- | Keyword for cabal version; required to be the top line in a cabal file+cabalVersionKeyword :: Map KeyWordName Completer+cabalVersionKeyword =+  Map.singleton "cabal-version:" $+    constantCompleter $+      -- We only suggest cabal versions newer than 2.2+      -- since we don't recommend using older ones.+      map (T.pack . showCabalSpecVersion) [CabalSpecV2_2 .. maxBound]++-- | Top level keywords of a cabal file.+--+-- TODO: we could add descriptions of field values and+-- then show them when inside the field's context+cabalKeywords :: Map KeyWordName Completer+cabalKeywords =+  Map.fromList+    [ ("name:", nameCompleter),+      ("version:", noopCompleter),+      ("build-type:", constantCompleter ["Simple", "Custom", "Configure", "Make"]),+      ("license:", weightedConstantCompleter licenseNames weightedLicenseNames),+      ("license-file:", filePathCompleter),+      ("license-files:", filePathCompleter),+      ("copyright:", noopCompleter),+      ("author:", noopCompleter),+      ("maintainer:", noopCompleter), -- email address, use git config?+      ("stability:", noopCompleter),+      ("homepage:", noopCompleter),+      ("bug-reports:", noopCompleter),+      ("package-url:", noopCompleter),+      ("synopsis:", noopCompleter),+      ("description:", noopCompleter),+      ("category:", noopCompleter),+      ("tested-with:", constantCompleter ["GHC"]),+      ("data-files:", filePathCompleter),+      ("data-dir:", directoryCompleter),+      ("extra-source-files:", filePathCompleter),+      ("extra-doc-files:", filePathCompleter),+      ("extra-tmp-files:", filePathCompleter)+    ]++-- | Map, containing all stanzas in a cabal file as keys+--  and lists of their possible nested keywords as values.+stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer)+stanzaKeywordMap =+  Map.fromList+    [ ("library", libraryFields <> libExecTestBenchCommons),+      ("executable", executableFields <> libExecTestBenchCommons),+      ("test-suite", testSuiteFields <> libExecTestBenchCommons),+      ("benchmark", benchmarkFields <> libExecTestBenchCommons),+      ("foreign-library", foreignLibraryFields <> libExecTestBenchCommons),+      ("flag", flagFields),+      ("source-repository", sourceRepositoryFields)+    ]++libraryFields :: Map KeyWordName Completer+libraryFields =+  Map.fromList+    [ ("exposed-modules:", modulesCompleter sourceDirsExtractionLibrary),+      ("virtual-modules:", noopCompleter),+      ("exposed:", constantCompleter ["True", "False"]),+      ("visibility:", constantCompleter ["private", "public"]),+      ("reexported-modules:", noopCompleter),+      ("signatures:", noopCompleter),+      ("other-modules:", modulesCompleter sourceDirsExtractionLibrary)+    ]++executableFields :: Map KeyWordName Completer+executableFields =+  Map.fromList+    [ ("main-is:", mainIsCompleter sourceDirsExtractionExecutable),+      ("scope:", constantCompleter ["public", "private"]),+      ("other-modules:", modulesCompleter sourceDirsExtractionExecutable)+    ]++testSuiteFields :: Map KeyWordName Completer+testSuiteFields =+  Map.fromList+    [ ("type:", constantCompleter ["exitcode-stdio-1.0", "detailed-0.9"]),+      ("main-is:", mainIsCompleter sourceDirsExtractionTestSuite),+      ("other-modules:", modulesCompleter sourceDirsExtractionTestSuite)+    ]++benchmarkFields :: Map KeyWordName Completer+benchmarkFields =+  Map.fromList+    [ ("type:", noopCompleter),+      ("main-is:", mainIsCompleter sourceDirsExtractionBenchmark),+      ("other-modules:", modulesCompleter sourceDirsExtractionBenchmark)+    ]++foreignLibraryFields :: Map KeyWordName Completer+foreignLibraryFields =+  Map.fromList+    [ ("type:", constantCompleter ["native-static", "native-shared"]),+      ("options:", constantCompleter ["standalone"]),+      ("mod-def-file:", filePathCompleter),+      ("lib-version-info:", noopCompleter),+      ("lib-version-linux:", noopCompleter)+    ]++sourceRepositoryFields :: Map KeyWordName Completer+sourceRepositoryFields =+  Map.fromList+    [ ( "type:",+        constantCompleter+          [ "darcs",+            "git",+            "svn",+            "cvs",+            "mercurial",+            "hg",+            "bazaar",+            "bzr",+            "arch",+            "monotone"+          ]+      ),+      ("location:", noopCompleter),+      ("module:", noopCompleter),+      ("branch:", noopCompleter),+      ("tag:", noopCompleter),+      ("subdir:", directoryCompleter)+    ]++flagFields :: Map KeyWordName Completer+flagFields =+  Map.fromList+    [ ("description:", noopCompleter),+      ("default:", constantCompleter ["True", "False"]),+      ("manual:", constantCompleter ["False", "True"]),+      ("lib-def-file:", noopCompleter),+      ("lib-version-info:", noopCompleter),+      ("lib-version-linux:", noopCompleter)+    ]++libExecTestBenchCommons :: Map KeyWordName Completer+libExecTestBenchCommons =+  Map.fromList+    [ ("build-depends:", noopCompleter),+      ("hs-source-dirs:", directoryCompleter),+      ("default-extensions:", noopCompleter),+      ("other-extensions:", noopCompleter),+      ("default-language:", constantCompleter ["GHC2021", "Haskell2010", "Haskell98"]),+      ("other-languages:", noopCompleter),+      ("build-tool-depends:", noopCompleter),+      ("buildable:", constantCompleter ["True", "False"]),+      ("ghc-options:", constantCompleter ghcOptions),+      ("ghc-prof-options:", constantCompleter ghcOptions),+      ("ghc-shared-options:", constantCompleter ghcOptions),+      ("ghcjs-options:", constantCompleter ghcOptions),+      ("ghcjs-prof-options:", constantCompleter ghcOptions),+      ("ghcjs-shared-options:", constantCompleter ghcOptions),+      ("includes:", filePathCompleter),+      ("install-includes:", filePathCompleter),+      ("include-dirs:", directoryCompleter),+      ("c-sources:", filePathCompleter),+      ("cxx-sources:", filePathCompleter),+      ("asm-sources:", filePathCompleter),+      ("cmm-sources:", filePathCompleter),+      ("js-sources:", filePathCompleter),+      ("extra-libraries:", noopCompleter),+      ("extra-ghci-libraries:", noopCompleter),+      ("extra-bundled-libraries:", noopCompleter),+      ("extra-lib-dirs:", directoryCompleter),+      ("cc-options:", noopCompleter),+      ("cpp-options:", noopCompleter),+      ("cxx-options:", noopCompleter),+      ("cmm-options:", noopCompleter),+      ("asm-options:", noopCompleter),+      ("ld-options:", noopCompleter),+      ("pkgconfig-depends:", noopCompleter),+      ("frameworks:", noopCompleter),+      ("extra-framework-dirs:", directoryCompleter),+      ("mixins:", noopCompleter)+    ]++-- | Contains a map of the most commonly used licenses, weighted by their popularity.+--+--  The data was extracted by Kleidukos from the alternative hackage frontend flora.pm.+weightedLicenseNames :: Map T.Text Double+weightedLicenseNames =+  fmap statisticsToWeight $+    Map.fromList+      [ ("BSD-3-Clause", 9955),+        ("MIT", 3336),+        ("GPL-3.0-only", 679),+        ("LicenseRef-OtherLicense", 521),+        ("Apache-2.0", 514),+        ("LicenseRef-GPL", 443),+        ("LicenseRef-PublicDomain", 318),+        ("MPL-2.0", 288),+        ("BSD-2-Clause", 174),+        ("GPL-2.0-only", 160),+        ("LicenseRef-LGPL", 146),+        ("LGPL-2.1-only", 112),+        ("LGPL-3.0-only", 100),+        ("AGPL-3.0-only", 96),+        ("ISC", 89),+        ("LicenseRef-Apache", 45),+        ("GPL-3.0-or-later", 43),+        ("BSD-2-Clause-Patent", 33),+        ("GPL-2.0-or-later", 21),+        ("CC0-1.0", 16),+        ("AGPL-3.0-or-later", 15),+        ("LGPL-2.1-or-later", 12),+        ("(BSD-2-Clause OR Apache-2.0)", 10),+        ("(Apache-2.0 OR MPL-2.0)", 8),+        ("LicenseRef-AGPL", 6),+        ("(BSD-3-Clause OR Apache-2.0)", 4),+        ("0BSD", 3),+        ("BSD-4-Clause", 3),+        ("LGPL-3.0-or-later", 3),+        ("LicenseRef-LGPL-2", 2),+        ("GPL-2.0-or-later AND BSD-3-Clause", 2),+        ("NONE", 2),+        ("Zlib", 2),+        ("(Apache-2.0 OR BSD-3-Clause)", 2),+        ("BSD-3-Clause AND GPL-2.0-or-later", 2),+        ("BSD-3-Clause AND GPL-3.0-or-later", 2)+      ]+  where+    -- Add weights to each usage value from above, the weights are chosen+    -- arbitrarily in order for completions to prioritize which licenses to+    -- suggest in a sensible way+    statisticsToWeight :: Int -> Double+    statisticsToWeight stat+      | stat < 10 = 0.1+      | stat < 20 = 0.3+      | stat < 50 = 0.4+      | stat < 100 = 0.5+      | stat < 500 = 0.6+      | stat < 650 = 0.7+      | otherwise = 0.9++ghcOptions :: [T.Text]+ghcOptions = map T.pack $ flagsForCompletion False
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++module Ide.Plugin.Cabal.Completion.Types where++import           Control.DeepSeq        (NFData)+import           Data.Hashable+import qualified Data.Text              as T+import           Data.Typeable+import           Development.IDE        as D+import           GHC.Generics+import qualified Ide.Plugin.Cabal.Parse as Parse++data Log+  = LogFileSplitError Position+  | -- | This should never occur since we extract the word to lookup from the same map we look it up in.+    LogUnknownKeyWordInContextError KeyWordName+  | -- | This should never occur since we extract the word to lookup from the same map we look it up in.+    LogUnknownStanzaNameInContextError StanzaName+  | LogFilePathCompleterIOError FilePath IOError+  | LogUseWithStaleFastNoResult+  | LogMapLookUpOfKnownKeyFailed T.Text+  deriving (Show)++instance Pretty Log where+  pretty = \case+    LogFileSplitError pos -> "An error occurred when trying to separate the lines of the cabal file at position:" <+> pretty pos+    LogUnknownKeyWordInContextError kw ->+      "Lookup of key word failed for:" <+> viaShow kw+    LogUnknownStanzaNameInContextError sn ->+      "Lookup of stanza name failed for:" <+> viaShow sn+    LogFilePathCompleterIOError fp ioErr ->+      "When trying to complete the file path:" <+> pretty fp <+> "the following unexpected IO error occurred" <+> viaShow ioErr+    LogUseWithStaleFastNoResult -> "Package description couldn't be read"+    LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key++type instance RuleResult GetCabalDiagnostics = Parse.GenericPackageDescription++data GetCabalDiagnostics = GetCabalDiagnostics+  deriving (Eq, Show, Typeable, Generic)++instance Hashable GetCabalDiagnostics++instance NFData GetCabalDiagnostics++-- | The context a cursor can be in within a cabal file.+--+--  We can be in stanzas or the top level,+--  and additionally we can be in a context where we have already+--  written a keyword but no value for it yet+type Context = (StanzaContext, FieldContext)++-- | Context inside a cabal file.+--  Used to decide which keywords to suggest.+data StanzaContext+  = -- | Top level context in a cabal file such as 'author'+    TopLevel+  | -- | Nested context in a cabal file, such as 'library'.+    --+    -- Stanzas have their own fields which differ from top-level fields.+    -- Each stanza must be named, such as 'executable exe',+    -- except for the main library.+    Stanza StanzaType (Maybe StanzaName)+  deriving (Eq, Show, Read)++-- | Keyword context in a cabal file.+--+--  Used to decide whether to suggest values or keywords.+data FieldContext+  = -- | Key word context, where a keyword+    -- occurs right before the current word+    -- to be completed+    KeyWord KeyWordName+  | -- | Keyword context where no keyword occurs+    -- right before the current word to be completed+    None+  deriving (Eq, Show, Read)++type KeyWordName = T.Text++type StanzaName = T.Text++type StanzaType = T.Text++-- | Information regarding the current completion status+--+--  Example: @"dir1/fi@ having been written to the file+--  would correspond to:+--+--  @+--    completionPrefix = "dir1/fi"+--    isStringNotation = LeftSide+--    ...+--  @+--+--  We define this type instead of simply using+--  VFS.PosPrefixInfo since e.g. for filepaths we+--  need more than just the word before the+--  cursor (as can be seen above),+--  since we want to capture the whole filepath+--  before the cursor.+--+--  We also use this type to wrap all information+--  necessary to complete filepaths and other values+--  in a cabal file.+data CabalPrefixInfo = CabalPrefixInfo+  { -- | text prefix to complete+    completionPrefix         :: T.Text,+    -- | Did the completion happen in the context of a string notation,+    -- i.e. are there apostrophes around the item to be completed+    isStringNotation         :: Maybe Apostrophe,+    -- | the current position of the cursor in the file+    completionCursorPosition :: Position,+    -- | range where completion is to be inserted+    completionRange          :: Range,+    -- | directory of the handled cabal file+    completionWorkingDir     :: FilePath,+    -- | filename of the handled cabal file+    completionFileName       :: T.Text+  }+  deriving (Eq, Show)++-- | Where are the apostrophes around the item to be completed?+--+--  'Surrounded' means the item to complete already has the necessary apostrophes,+--  while 'LeftSide' means, a closing apostrophe has to be added after the completion item.+data Apostrophe = Surrounded | LeftSide+  deriving (Eq, Ord, Show)++-- | Wraps a completion in apostrophes where appropriate.+--+--  If a completion starts with an apostrophe we want to end it with an apostrophe.+--  If a completed filepath contains a space, it can only be written in the cabal+--  file if it is wrapped in apostrophes, thus we wrap it.+applyStringNotation :: Maybe Apostrophe -> T.Text -> T.Text+applyStringNotation (Just Surrounded) compl = compl+applyStringNotation (Just LeftSide) compl = compl <> "\""+applyStringNotation Nothing compl+  | Just _ <- T.find (== ' ') compl = "\"" <> compl <> "\""+  | otherwise = compl
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+module Ide.Plugin.Cabal.Diagnostics+( errorDiagnostic+, warningDiagnostic+, positionFromCabalPosition+  -- * Re-exports+, FileDiagnostic+, Diagnostic(..)+)+where++import qualified Data.Text                   as T+import           Development.IDE             (FileDiagnostic,+                                              ShowDiagnostic (ShowDiag))+import           Distribution.Fields         (showPError, showPWarning)+import qualified Ide.Plugin.Cabal.Parse      as Lib+import           Ide.PluginUtils             (extendNextLine)+import           Language.LSP.Protocol.Types (Diagnostic (..),+                                              DiagnosticSeverity (..),+                                              NormalizedFilePath,+                                              Position (Position),+                                              Range (Range),+                                              fromNormalizedFilePath)++-- | Produce a diagnostic from a Cabal parser error+errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic+errorDiagnostic fp err@(Lib.PError pos _) =+  mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg+  where+    msg = T.pack $ showPError (fromNormalizedFilePath fp) err++-- | Produce a diagnostic from a Cabal parser warning+warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic+warningDiagnostic fp warning@(Lib.PWarning _ pos _) =+  mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg+  where+    msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning++-- | The Cabal parser does not output a _range_ for a warning/error,+-- only a single source code 'Lib.Position'.+-- We define the range to be _from_ this position+-- _to_ the first column of the next line.+toBeginningOfNextLine :: Lib.Position -> Range+toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos+   where+    pos = positionFromCabalPosition cabalPos++-- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands.+--+-- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based,+-- while Cabal is one-based.+--+-- >>> positionFromCabalPosition $ Lib.Position 1 1+-- Position 0 0+positionFromCabalPosition :: Lib.Position -> Position+positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col')+  where+    -- LSP is zero-based, Cabal is one-based+    line' = line-1+    col' = column-1++-- | Create a 'FileDiagnostic'+mkDiag+  :: NormalizedFilePath+  -- ^ Cabal file path+  -> T.Text+  -- ^ Where does the diagnostic come from?+  -> DiagnosticSeverity+  -- ^ Severity+  -> Range+  -- ^ Which source code range should the editor highlight?+  -> T.Text+  -- ^ The message displayed by the editor+  -> FileDiagnostic+mkDiag file diagSource sev loc msg = (file, ShowDiag,)+    Diagnostic+    { _range    = loc+    , _severity = Just sev+    , _source   = Just diagSource+    , _message  = msg+    , _code     = Nothing+    , _tags     = Nothing+    , _relatedInformation = Nothing+    , _codeDescription = Nothing+    , _data_ = Nothing+    }
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+module Ide.Plugin.Cabal.LicenseSuggest+( licenseErrorSuggestion+, licenseErrorAction+, licenseNames+  -- * Re-exports+, T.Text+, Diagnostic(..)+)+where++import qualified Data.Map                    as Map+import qualified Data.Text                   as T+import           Language.LSP.Protocol.Types (CodeAction (CodeAction),+                                              CodeActionKind (CodeActionKind_QuickFix),+                                              Diagnostic (..),+                                              Position (Position),+                                              Range (Range),+                                              TextEdit (TextEdit), Uri,+                                              WorkspaceEdit (WorkspaceEdit))+import           Text.Regex.TDFA++import qualified Data.List                   as List+import           Distribution.SPDX.LicenseId (licenseId)+import qualified Text.Fuzzy.Parallel         as Fuzzy++-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic',+--   if it represents an "Unknown SPDX license identifier"-error along+--   with a suggestion, then return a 'CodeAction' for replacing the+--   the incorrect license identifier with the suggestion.+licenseErrorAction+  :: Uri+  -- ^ File for which the diagnostic was generated+  -> Diagnostic+  -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'+  -> [CodeAction]+licenseErrorAction uri diag =+  mkCodeAction <$> licenseErrorSuggestion (_message diag)+  where+    mkCodeAction (original, suggestion) =+      let+        -- The Cabal parser does not output the _range_ of the incorrect license identifier,+        -- only a single source code position. Consequently, in 'Ide.Plugin.Cabal.Diag.errorDiagnostic'+        -- we define the range to be from the returned position the first column of the next line.+        -- Since the "replace" code action replaces this range, we need to modify the range to+        -- start at the first character of the invalid license identifier. We achieve this by+        -- subtracting the length of the identifier from the beginning of the range.+        adjustRange (Range (Position line col) rangeTo) =+          Range (Position line (col - fromIntegral (T.length original))) rangeTo+        title = "Replace with " <> suggestion+        -- We must also add a newline character to the replacement since the range returned by+        -- 'Ide.Plugin.Cabal.Diag.errorDiagnostic' ends at the beginning of the following line.+        tedit = [TextEdit (adjustRange $ _range diag) (suggestion <> "\n")]+        edit  = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing+      in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing++-- | License name of every license supported by cabal+licenseNames :: [T.Text]+licenseNames = map (T.pack . licenseId) [minBound .. maxBound]++-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic',+--   provide possible corrections for SPDX license identifiers+--   based on the list specified in Cabal.+--   Results are sorted by best fit, and prefer solutions that have smaller+--   length distance to the original word.+--+-- >>> take 2 $ licenseErrorSuggestion (T.pack "Unknown SPDX license identifier: 'BSD3'")+-- [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")]+licenseErrorSuggestion ::+  T.Text+  -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'+  -> [(T.Text, T.Text)]+  -- ^ (Original (incorrect) license identifier, suggested replacement)+licenseErrorSuggestion msg =+   (getMatch <$> msg =~~ regex) >>= \case+          [original] ->+            let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults original licenseNames+            in [(original,candidate) | candidate <- List.sortBy (lengthDistance original) matches]+          _ -> []+  where+    regex :: T.Text+    regex = "Unknown SPDX license identifier: '(.*)'"+    getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text]+    getMatch (_, _, _, results) = results+    lengthDistance original x1 x2 = abs (T.length original - T.length x1) `compare` abs (T.length original - T.length x2)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs view
@@ -0,0 +1,27 @@+module Ide.Plugin.Cabal.Parse+( parseCabalFileContents+  -- * Re-exports+, FilePath+, NonEmpty(..)+, PWarning(..)+, Version+, PError(..)+, Position(..)+, GenericPackageDescription(..)+) where++import qualified Data.ByteString                              as BS+import           Data.List.NonEmpty                           (NonEmpty (..))+import           Distribution.Fields                          (PError (..),+                                                               PWarning (..))+import           Distribution.Fields.ParseResult              (runParseResult)+import           Distribution.PackageDescription.Parsec       (parseGenericPackageDescription)+import           Distribution.Parsec.Position                 (Position (..))+import           Distribution.Types.GenericPackageDescription (GenericPackageDescription (..))+import           Distribution.Types.Version                   (Version)++parseCabalFileContents+  :: BS.ByteString -- ^ UTF-8 encoded bytestring+  -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription)+parseCabalFileContents bs =+  pure $ runParseResult (parseGenericPackageDescription bs)
+ plugins/hls-cabal-plugin/test/Completer.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings        #-}++module Completer where++import           Control.Lens                                   ((^.), (^?))+import           Control.Lens.Prism+import qualified Data.ByteString                                as ByteString+import           Data.Maybe                                     (mapMaybe)+import qualified Data.Text                                      as T+import qualified Development.IDE.Plugin.Completions.Types       as Ghcide+import           Distribution.PackageDescription.Parsec         (parseGenericPackageDescriptionMaybe)+import           Ide.Plugin.Cabal.Completion.Completer.FilePath+import           Ide.Plugin.Cabal.Completion.Completer.Module+import           Ide.Plugin.Cabal.Completion.Completer.Paths+import           Ide.Plugin.Cabal.Completion.Completer.Types    (CompleterData (..))+import           Ide.Plugin.Cabal.Completion.Completions+import           Ide.Plugin.Cabal.Completion.Types              (CabalPrefixInfo (..),+                                                                 StanzaName)+import           Ide.Plugin.Cabal.Parse                         (GenericPackageDescription)+import qualified Language.LSP.Protocol.Lens                     as L+import           System.FilePath+import           Test.Hls+import           Utils++completerTests :: TestTree+completerTests =+  testGroup+    "Completer Tests"+    [ basicCompleterTests,+      fileCompleterTests,+      filePathCompletionContextTests,+      directoryCompleterTests,+      completionHelperTests,+      filePathExposedModulesTests,+      exposedModuleCompleterTests+    ]++basicCompleterTests :: TestTree+basicCompleterTests =+  testGroup+    "Basic Completer Tests"+    [ runCabalTestCaseSession "In stanza context - stanza should not be suggested" "" $ do+        doc <- openDoc "completer.cabal" "cabal"+        compls <- getCompletions doc (Position 11 7)+        let complTexts = getTextEditTexts compls+        liftIO $ assertBool "does not suggest library" $ "library" `notElem` complTexts+        liftIO $ assertBool "suggests library keyword" $ "extra-libraries:" `elem` complTexts+    , runCabalTestCaseSession "In top level context - stanza should be suggested" "" $ do+        doc <- openDoc "completer.cabal" "cabal"+        compls <- getCompletions doc (Position 8 2)+        let complTexts = getTextEditTexts compls+        liftIO $ assertBool "suggests benchmark" $ "benchmark" `elem` complTexts+    , runCabalTestCaseSession "Main-is completions should be relative to hs-source-dirs of same stanza" "filepath-completions" $ do+        doc <- openDoc "main-is.cabal" "cabal"+        compls <- getCompletions doc (Position 10 12)+        let complTexts = getTextEditTexts compls+        liftIO $ assertBool "suggests f2" $ "./f2.hs" `elem` complTexts+        liftIO $ assertBool "does not suggest" $ "./Content.hs" `notElem` complTexts+    ]+    where+      getTextEditTexts :: [CompletionItem] -> [T.Text]+      getTextEditTexts compls = mapMaybe (^? L.textEdit . _Just . _L . L.newText) compls++fileCompleterTests :: TestTree+fileCompleterTests =+  testGroup+    "File Completer Tests"+    [ testCase "Current Directory" $ do+        completions <- completeFilePath "" filePathComplTestDir+        completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"],+      testCase "Current Directory - alternative writing" $ do+        completions <- completeFilePath "./" filePathComplTestDir+        completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"],+      testCase "Current Directory - hidden file start" $ do+        completions <- completeFilePath "." filePathComplTestDir+        completions @?== ["./Content.hs", "./.hidden", "./textfile.txt", "./main-is.cabal"],+      testCase "Current Directory - incomplete directory path written" $ do+        completions <- completeFilePath "di" filePathComplTestDir+        completions @?== ["./dir1/", "./dir2/"],+      testCase "Current Directory - incomplete filepath written" $ do+        completions <- completeFilePath "te" filePathComplTestDir+        completions @?== ["./Content.hs", "./textfile.txt"],+      testCase "Subdirectory" $ do+        completions <- completeFilePath "dir1/" filePathComplTestDir+        completions @?== ["dir1/f1.txt", "dir1/f2.hs"],+      testCase "Subdirectory - incomplete filepath written" $ do+        completions <- completeFilePath "dir2/dir3/MA" filePathComplTestDir+        completions @?== ["dir2/dir3/MARKDOWN.md"],+      testCase "Nonexistent directory" $ do+        completions <- completeFilePath "dir2/dir4/" filePathComplTestDir+        completions @?== []+    ]+  where+    completeFilePath :: T.Text -> TestName -> IO [T.Text]+    completeFilePath written dirName = do+      completer <- filePathCompleter mempty $ mkCompleterData $ simpleCabalPrefixInfoFromFp written dirName+      pure $ fmap extract completer++filePathCompletionContextTests :: TestTree+filePathCompletionContextTests =+  testGroup+    "File Path Completion Context Tests"+    [ testCase "empty file - start" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "" 0 0)+        completionPrefix complContext @?= "",+      testCase "only whitespaces" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "   " 0 3)+        completionPrefix complContext @?= "",+      testCase "simple filepath" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "   src/" 0 7)+        completionPrefix complContext @?= "src/",+      testCase "simple filepath - starting apostrophe" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "   \"src/" 0 8)+        completionPrefix complContext @?= "src/",+      testCase "simple filepath - starting apostrophe, already closed" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "   \"src/\"" 0 8)+        completionPrefix complContext @?= "src/",+      testCase "second filepath - starting apostrophe" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/" 0 12)+        completionPrefix complContext @?= "src/",+      testCase "middle filepath - starting apostrophe" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/ fp2.txt" 0 12)+        completionPrefix complContext @?= "src/",+      testCase "middle filepath - starting apostrophe, already closed" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.t xt \"src\" fp2.txt" 0 12)+        completionPrefix complContext @?= "src",+      testCase "middle filepath - starting apostrophe, already closed" $ do+        let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "\"fp.txt\" \"src fp2.txt" 0 13)+        completionPrefix complContext @?= "src",+      testCase "Current Directory" $ do+        compls <-+          listFileCompletions+            mempty+            PathCompletionInfo+              { isStringNotationPath = Nothing,+                pathSegment = "",+                queryDirectory = "",+                workingDirectory = filePathComplTestDir+              }+        compls @?== [".hidden", "Content.hs", "dir1/", "dir2/", "textfile.txt", "main-is.cabal"],+      testCase "In directory" $ do+        compls <-+          listFileCompletions+            mempty+            PathCompletionInfo+              { isStringNotationPath = Nothing,+                pathSegment = "",+                queryDirectory = "dir1/",+                workingDirectory = filePathComplTestDir+              }+        compls @?== ["f1.txt", "f2.hs"]+    ]+  where+    simplePosPrefixInfo :: T.Text -> UInt -> UInt -> Ghcide.PosPrefixInfo+    simplePosPrefixInfo lineString linePos charPos =+      Ghcide.PosPrefixInfo+        { Ghcide.fullLine = lineString,+          Ghcide.prefixScope = "",+          Ghcide.prefixText = "",+          Ghcide.cursorPos = Position linePos charPos+        }++directoryCompleterTests :: TestTree+directoryCompleterTests =+  testGroup+    "Directory Completer Tests"+    [ testCase "Current Directory" $ do+        completions <- completeDirectory "" filePathComplTestDir+        completions @?== ["./dir1/", "./dir2/"],+      testCase "Current Directory - alternative writing" $ do+        completions <- completeDirectory "./" filePathComplTestDir+        completions @?== ["./dir1/", "./dir2/"],+      testCase "Current Directory - incomplete directory path written" $ do+        completions <- completeDirectory "di" filePathComplTestDir+        completions @?== ["./dir1/", "./dir2/"],+      testCase "Current Directory - incomplete filepath written" $ do+        completions <- completeDirectory "te" filePathComplTestDir+        completions @?== [],+      testCase "Subdirectory - no more directories found" $ do+        completions <- completeDirectory "dir1/" filePathComplTestDir+        completions @?== [],+      testCase "Subdirectory - available subdirectory" $ do+        completions <- completeDirectory "dir2/" filePathComplTestDir+        completions @?== ["dir2/dir3/"],+      testCase "Nonexistent directory" $ do+        completions <- completeDirectory "dir2/dir4/" filePathComplTestDir+        completions @?== []+    ]+  where+    completeDirectory :: T.Text -> TestName -> IO [T.Text]+    completeDirectory written dirName = do+      completer <- directoryCompleter mempty $ mkCompleterData $ simpleCabalPrefixInfoFromFp written dirName+      pure $ fmap extract completer++completionHelperTests :: TestTree+completionHelperTests =+  testGroup+    "Completion Helper Tests"+    [ testCase "get FilePath - partly written file path" $ do+        getFilePathCursorPrefix "src/a" 0 5 @?= "src/a",+      testCase "get FilePath - ignores spaces" $ do+        getFilePathCursorPrefix "  src/a" 0 7 @?= "src/a",+      testCase "get FilePath - ignores spaces and keyword" $ do+        getFilePathCursorPrefix "license-file: src/a" 0 19 @?= "src/a",+      testCase "get FilePath - with apostrophe, ignores spaces and keyword" $ do+        getFilePathCursorPrefix "license-file: \"src/a" 0 20 @?= "src/a",+      testCase "get FilePath - ignores list of filepaths beforehand, space separated" $ do+        getFilePathCursorPrefix "  ./text.txt file.h" 0 19 @?= "file.h",+      testCase "get FilePath - ignores list of filepaths after, space separated" $ do+        getFilePathCursorPrefix "  ./text.t file.h" 0 10 @?= "./text.t",+      testCase "get FilePath - ignores list of filepaths and rest of filepath after, space separated" $ do+        getFilePathCursorPrefix "  ./text.t file.h" 0 6 @?= "./te",+      testCase "get FilePath - ignores list of filepaths beforehand, multiple space separated" $ do+        getFilePathCursorPrefix "  ./text.txt   file.h" 0 21 @?= "file.h",+      testCase "get FilePath - ignores list of filepaths beforehand, comma separated" $ do+        getFilePathCursorPrefix "  ./text.txt, file.h" 0 20 @?= "file.h",+      testCase "get FilePath - ignores list of filepaths beforehand, comma separated, many whitespaces" $ do+        getFilePathCursorPrefix "  ./text.txt,   file.h" 0 22 @?= "file.h",+      testCase "get FilePath - ignores list of filepaths beforehand, comma separated, no whitespace" $ do+        getFilePathCursorPrefix "  ./text.txt,file.h" 0 19 @?= "file.h",+      testCase "get FilePath - with apostrophes, ignores list of filepaths beforehand" $ do+        getFilePathCursorPrefix "  \"./text.txt\" \"file.h" 0 23 @?= "file.h",+      testCase "get FilePath - ignores list of filepaths with apostrophe beforehand" $ do+        getFilePathCursorPrefix "  \"./text.txt\" file.h" 0 22 @?= "file.h"+    ]+  where+    getFilePathCursorPrefix :: T.Text -> UInt -> UInt -> T.Text+    getFilePathCursorPrefix lineString linePos charPos =+      completionPrefix . getCabalPrefixInfo "" $+        Ghcide.PosPrefixInfo+          { Ghcide.fullLine = lineString,+            Ghcide.prefixScope = "",+            Ghcide.prefixText = "",+            Ghcide.cursorPos = Position linePos charPos+          }++filePathExposedModulesTests :: TestTree+filePathExposedModulesTests =+  testGroup+    "Filepaths for Exposed Modules Tests"+    [ testCase "Root dir" $ do+        exposed <- callFilePathsForExposedModules ["./"]+        exposed @?== ["Dir1.", "File1"],+      testCase "Nested path" $ do+        exposed <- callFilePathsForExposedModules ["./Dir1/Dir2/"]+        exposed @?== ["File2"],+      testCase "Nested empty dir" $ do+        exposed <- callFilePathsForExposedModules ["./Dir1/Dir2/Dir4"]+        exposed @?== [],+      testCase "Two dirs" $ do+        exposed <- callFilePathsForExposedModules ["./Dir1/", "Dir1/Dir3/Dir4/"]+        exposed @?== ["Dir2.", "Dir3.", "File3"]+    ]+  where+    callFilePathsForExposedModules :: [FilePath] -> IO [T.Text]+    callFilePathsForExposedModules srcDirs = do+      let prefInfo = simpleCabalPrefixInfoFromFp "" exposedTestDir+      filePathsForExposedModules mempty srcDirs prefInfo++exposedModuleCompleterTests :: TestTree+exposedModuleCompleterTests =+  testGroup+    "Exposed Modules Completer Tests"+    [ testCase "Top level single source dir, library" $ do+        completions <- callModulesCompleter Nothing sourceDirsExtractionLibrary ""+        completions @?== ["Dir2.", "Dir3."],+      testCase "Top level single source dir, benchmark, with prefix" $ do+        completions <- callModulesCompleter (Just "benchie") sourceDirsExtractionBenchmark "Fi"+        completions @?== ["File1"],+      testCase "Top level single source dir, named executable" $ do+        completions <- callModulesCompleter (Just "executie") sourceDirsExtractionExecutable ""+        completions @?== ["File1", "Dir1.", "Dir2.", "Dir3."],+      testCase "Top level single source dir, named executable" $ do+        completions <- callModulesCompleter (Just "exe-not-so-cutie") sourceDirsExtractionExecutable ""+        completions @?== ["File2", "Dir4."],+      testCase "Top level single source dir, nonexistent name" $ do+        completions <- callModulesCompleter (Just "exe-the-beste") sourceDirsExtractionExecutable ""+        completions @?== [],+      testCase "Top level single source dir, testsuite, with prefix" $ do+        completions <- callModulesCompleter (Just "suitor") sourceDirsExtractionTestSuite "3"+        completions @?== ["File3"],+      testCase "Name nothing but not library" $ do+        completions <- callModulesCompleter Nothing sourceDirsExtractionTestSuite "3"+        completions @?== []+    ]+  where+    simpleCompleterData :: Maybe StanzaName -> FilePath -> T.Text -> CompleterData+    simpleCompleterData sName dir pref = do+      CompleterData+        { cabalPrefixInfo = simpleExposedCabalPrefixInfo pref dir,+          getLatestGPD = do+            cabalContents <- ByteString.readFile $ testDataDir </> "exposed.cabal"+            pure $ parseGenericPackageDescriptionMaybe cabalContents,+          stanzaName = sName+        }+    callModulesCompleter :: Maybe StanzaName -> (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> T.Text -> IO [T.Text]+    callModulesCompleter sName func prefix = do+      let cData = simpleCompleterData sName testDataDir prefix+      completer <- modulesCompleter func mempty cData+      pure $ fmap extract completer++mkCompleterData :: CabalPrefixInfo -> CompleterData+mkCompleterData prefInfo = CompleterData {getLatestGPD = undefined, cabalPrefixInfo = prefInfo, stanzaName = Nothing}++exposedTestDir :: FilePath+exposedTestDir = addTrailingPathSeparator $ testDataDir </> "src-modules"++simpleExposedCabalPrefixInfo :: T.Text -> FilePath -> CabalPrefixInfo+simpleExposedCabalPrefixInfo prefix fp =+  CabalPrefixInfo+    { completionPrefix = prefix,+      isStringNotation = Nothing,+      completionCursorPosition = Position 0 0,+      completionRange = Range (Position 0 0) (Position 0 0),+      completionWorkingDir = fp,+      completionFileName = "exposed.cabal"+    }++extract :: CompletionItem -> T.Text+extract item = case item ^. L.textEdit of+  Just (InL v) -> v ^. L.newText+  _            -> error ""
+ plugins/hls-cabal-plugin/test/Context.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE OverloadedStrings        #-}++module Context where++import           Control.Monad.Trans.Maybe                   (runMaybeT)+import qualified Data.Text                                   as T+import qualified Data.Text.Utf16.Rope.Mixed                  as Rope+import           Ide.Plugin.Cabal+import           Ide.Plugin.Cabal.Completion.Completer.Paths+import           Ide.Plugin.Cabal.Completion.Completions+import           Ide.Plugin.Cabal.Completion.Types           (Context,+                                                              FieldContext (KeyWord, None),+                                                              StanzaContext (Stanza, TopLevel))+import           Test.Hls+import           Utils                                       as T++cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log+cabalPlugin = mkPluginTestDescriptor descriptor "cabal context"++contextTests :: TestTree+contextTests =+    testGroup+        "Context Tests "+        [ pathCompletionInfoFromCompletionContextTests+        , getContextTests+        ]++pathCompletionInfoFromCompletionContextTests :: TestTree+pathCompletionInfoFromCompletionContextTests =+    testGroup+        "Completion Info to Completion Context Tests"+        [ testCase "Current Directory" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "" testDataDir+            queryDirectory complInfo @?= "./"+        , testCase "Current Directory - partly written next" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "di" testDataDir+            queryDirectory complInfo @?= "./"+            pathSegment complInfo @?= "di"+        , testCase "Current Directory - alternative writing" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "./" testDataDir+            queryDirectory complInfo @?= "./"+        , testCase "Subdirectory" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/" testDataDir+            queryDirectory complInfo @?= "dir1/"+            pathSegment complInfo @?= ""+        , testCase "Subdirectory - partly written next" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/d" testDataDir+            queryDirectory complInfo @?= "dir1/"+            pathSegment complInfo @?= "d"+        , testCase "Subdirectory - partly written next" $ do+            let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/dir2/d" testDataDir+            queryDirectory complInfo @?= "dir1/dir2/"+            pathSegment complInfo @?= "d"+        ]++getContextTests :: TestTree+getContextTests =+    testGroup+        "Context Tests"+        [ testCase "Empty File - Start" $ do+            -- for a completely empty file, the context needs to+            -- be top level without a specified keyword+            ctx <- callGetContext (Position 0 0) "" [""]+            ctx @?= (TopLevel, None)+        , testCase "Cabal version keyword - no value, no space after :" $ do+            -- on a file, where the keyword is already written+            -- the context should still be toplevel but the keyword should be recognized+            ctx <- callGetContext (Position 0 14) "" ["cabal-version:"]+            ctx @?= (TopLevel, KeyWord "cabal-version:")+        , testCase "Cabal version keyword - cursor in keyword" $ do+            -- on a file, where the keyword is already written+            -- but the cursor is in the middle of the keyword,+            -- we are not in a keyword context+            ctx <- callGetContext (Position 0 5) "cabal" ["cabal-version:"]+            ctx @?= (TopLevel, None)+        , testCase "Cabal version keyword - no value, many spaces" $ do+            -- on a file, where the "cabal-version:" keyword is already written+            -- the context should still be top level but the keyword should be recognized+            ctx <- callGetContext (Position 0 45) "" ["cabal-version:" <> T.replicate 50 " "]+            ctx @?= (TopLevel, KeyWord "cabal-version:")+        , testCase "Cabal version keyword - keyword partly written" $ do+            -- in the first line of the file, if the keyword+            -- has not been written completely, the keyword context+            -- should still be None+            ctx <- callGetContext (Position 0 5) "cabal" ["cabal"]+            ctx @?= (TopLevel, None)+        , testCase "Cabal version keyword - value partly written" $ do+            -- in the first line of the file, if the keyword+            -- has not been written completely, the keyword context+            -- should still be None+            ctx <- callGetContext (Position 0 17) "1." ["cabal-version: 1."]+            ctx @?= (TopLevel, KeyWord "cabal-version:")+        , testCase "Inside Stanza - no keyword" $ do+            -- on a file, where the library stanza has been defined+            -- but no keyword is defined afterwards, the stanza context should be recognized+            ctx <- callGetContext (Position 3 2) "" libraryStanzaData+            ctx @?= (Stanza "library" Nothing, None)+        , testCase "Inside Stanza - keyword, no value" $ do+            -- on a file, where the library stanza and a keyword+            -- has been defined, the keyword and stanza should be recognized+            ctx <- callGetContext (Position 4 21) "" libraryStanzaData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , expectFailBecause "While not valid, it is not that important to make the code more complicated for this" $+            testCase "Cabal version keyword - no value, next line" $ do+                -- if the cabal version keyword has been written but without a value,+                -- in the next line we still should be in top level context with no keyword+                -- since the cabal version keyword and value pair need to be in the same line+                ctx <- callGetContext (Position 1 2) "" ["cabal-version:", ""]+                ctx @?= (TopLevel, None)+        , testCase "Non-cabal-version keyword - no value, next line indentented position" $ do+            -- if a keyword, other than the cabal version keyword has been written+            -- with no value, in the next line we still should be in top level keyword context+            -- of the keyword with no value, since its value may be written in the next line+            ctx <- callGetContext (Position 2 4) "" topLevelData+            ctx @?= (TopLevel, KeyWord "name:")+        , testCase "Non-cabal-version keyword - no value, next line at start" $ do+            -- if a keyword, other than the cabal version keyword has been written+            -- with no value, in the next line we still should be in top level context+            -- but not the keyword's, since it is not viable to write a value for a+            -- keyword a the start of the next line+            ctx <- callGetContext (Position 2 0) "" topLevelData+            ctx @?= (TopLevel, None)+        , testCase "Toplevel after stanza partially written" $ do+            ctx <- callGetContext (Position 6 2) "ma" libraryStanzaData+            ctx @?= (TopLevel, None)+        , testCase "Non-cabal-version keyword - no value, multiple lines between" $ do+            -- if a keyword, other than the cabal version keyword has been written+            -- with no value, even with multiple lines in between we can still write the+            -- value corresponding to the keyword+            ctx <- callGetContext (Position 5 4) "" topLevelData+            ctx @?= (TopLevel, KeyWord "name:")+        , testCase "Keyword inside stanza - cursor indented more than keyword in next line" $ do+            -- if a keyword, other than the cabal version keyword has been written+            -- in a stanza context with no value, then the value may be written in the next line,+            -- when the cursor is indented more than the keyword+            ctx <- callGetContext (Position 5 8) "" libraryStanzaData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , testCase "Keyword inside stanza - cursor indented less than keyword in next line" $ do+            -- if a keyword, other than the cabal version keyword has been written+            -- in a stanza context with no value, then the value may not be written in the next line,+            -- when the cursor is indented less than the keyword+            ctx <- callGetContext (Position 5 2) "" libraryStanzaData+            ctx @?= (Stanza "library" Nothing, None)+        , testCase "Keyword inside stanza - cursor at start of next line" $ do+            -- in a stanza context with no value the value may not be written in the next line,+            -- when the cursor is not indented and we are in the top level context+            ctx <- callGetContext (Position 5 0) "" libraryStanzaData+            ctx @?= (TopLevel, None)+        , testCase "Top level - cursor in later line with partially written value" $ do+            ctx <- callGetContext (Position 5 13) "eee" topLevelData+            ctx @?= (TopLevel, KeyWord "name:")+        , testCase "Named Stanza" $ do+            ctx <- callGetContext (Position 2 18) "" executableStanzaData+            ctx @?= (Stanza "executable" (Just "exeName"), None)+        ]+  where+    callGetContext :: Position -> T.Text -> [T.Text] -> IO Context+    callGetContext pos pref ls = do+        runMaybeT (getContext mempty (simpleCabalPrefixInfoFromPos pos pref) (Rope.fromText $ T.unlines ls))+            >>= \case+                Nothing -> assertFailure "Context must be found"+                Just ctx -> pure ctx++-- ------------------------------------------------------------------------+-- Test Data+-- ------------------------------------------------------------------------++libraryStanzaData :: [T.Text]+libraryStanzaData =+    [ "cabal-version:      3.0"+    , "name:               simple-cabal"+    , "library "+    , "    default-language: Haskell98"+    , "    build-depends:    "+    , "           "+    , "ma  "+    ]++executableStanzaData :: [T.Text]+executableStanzaData =+    [ "cabal-version:      3.0"+    , "name:               simple-cabal"+    , "executable exeName"+    , "    default-language: Haskell2010"+    , "    hs-source-dirs: test/preprocessor"+    ]++topLevelData :: [T.Text]+topLevelData =+    [ "cabal-version:      3.0"+    , "name:"+    , ""+    , ""+    , ""+    , "          eee"+    ]
+ plugins/hls-cabal-plugin/test/Main.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedLabels         #-}+{-# LANGUAGE OverloadedStrings        #-}++module Main (+    main,+) where++import           Completer                       (completerTests)+import           Context                         (contextTests)+import           Control.Lens                    ((^.))+import           Control.Monad                   (guard)+import qualified Data.ByteString                 as BS+import           Data.Either                     (isRight)+import           Data.Row+import qualified Data.Text                       as T+import qualified Data.Text                       as Text+import           Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)+import qualified Ide.Plugin.Cabal.Parse          as Lib+import qualified Language.LSP.Protocol.Lens      as L+import           System.FilePath+import           Test.Hls+import           Utils++main :: IO ()+main = do+    defaultTestRunner $+        testGroup+            "Cabal Plugin Tests"+            [ unitTests+            , pluginTests+            , completerTests+            , contextTests+            ]++-- ------------------------------------------------------------------------+-- Unit Tests+-- ------------------------------------------------------------------------++unitTests :: TestTree+unitTests =+    testGroup+        "Unit Tests"+        [ cabalParserUnitTests+        , codeActionUnitTests+        ]++cabalParserUnitTests :: TestTree+cabalParserUnitTests =+    testGroup+        "Parsing Cabal"+        [ testCase "Simple Parsing works" $ do+            (warnings, pm) <- Lib.parseCabalFileContents =<< BS.readFile (testDataDir </> "simple.cabal")+            liftIO $ do+                null warnings @? "Found unexpected warnings"+                isRight pm @? "Failed to parse GenericPackageDescription"+        ]++codeActionUnitTests :: TestTree+codeActionUnitTests =+    testGroup+        "Code Action Tests"+        [ testCase "Unknown format" $ do+            -- the message has the wrong format+            licenseErrorSuggestion "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= []+        , testCase "BSD-3-Clause" $ do+            take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?")+                @?= [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")]+        , testCase "MiT" $ do+            -- contains no suggestion+            take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'MiT'")+                @?= [("MiT", "MIT"), ("MiT", "MIT-0")]+        ]++-- ------------------------ ------------------------------------------------+-- Integration Tests+-- ------------------------------------------------------------------------++pluginTests :: TestTree+pluginTests =+    testGroup+        "Plugin Tests"+        [ testGroup+            "Diagnostics"+            [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do+                doc <- openDoc "invalid.cabal" "cabal"+                diags <- waitForDiagnosticsFromSource doc "cabal"+                unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]+                liftIO $ do+                    length diags @?= 1+                    unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)+                    unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error+            , runCabalTestCaseSession "Clears diagnostics" "" $ do+                doc <- openDoc "invalid.cabal" "cabal"+                diags <- waitForDiagnosticsFrom doc+                unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]+                liftIO $ do+                    length diags @?= 1+                    unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)+                    unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error+                _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n"+                newDiags <- waitForDiagnosticsFrom doc+                liftIO $ newDiags @?= []+            , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do+                hsDoc <- openDoc "A.hs" "haskell"+                expectNoMoreDiagnostics 1 hsDoc "typechecking"+                cabalDoc <- openDoc "simple-cabal.cabal" "cabal"+                expectNoMoreDiagnostics 1 cabalDoc "parsing"+            , ignoreTestBecause "Testcase is flaky for certain GHC versions (e.g. 9.2.5). See #3333 for details." $ do+                runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "simple-cabal" $ do+                    hsDoc <- openDoc "A.hs" "haskell"+                    expectNoMoreDiagnostics 1 hsDoc "typechecking"+                    cabalDoc <- openDoc "simple-cabal.cabal" "cabal"+                    expectNoMoreDiagnostics 1 cabalDoc "parsing"+                    let theRange = Range (Position 3 20) (Position 3 23)+                    -- Invalid license+                    changeDoc+                        cabalDoc+                        [ TextDocumentContentChangeEvent $+                            InL $+                                #range+                                    .== theRange+                                    .+ #rangeLength+                                    .== Nothing+                                    .+ #text+                                    .== "MIT3"+                        ]+                    cabalDiags <- waitForDiagnosticsFrom cabalDoc+                    unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"]+                    expectNoMoreDiagnostics 1 hsDoc "typechecking"+                    liftIO $ do+                        length cabalDiags @?= 1+                        unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)+                        unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error+            ]+        , testGroup+            "Code Actions"+            [ runCabalTestCaseSession "BSD-3" "" $ do+                doc <- openDoc "licenseCodeAction.cabal" "cabal"+                diags <- waitForDiagnosticsFromSource doc "cabal"+                reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]+                liftIO $ do+                    length diags @?= 1+                    reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)+                    reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error+                [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0))+                executeCodeAction codeAction+                contents <- documentContents doc+                liftIO $+                    contents+                        @?= Text.unlines+                            [ "cabal-version:      3.0"+                            , "name:               licenseCodeAction"+                            , "version:            0.1.0.0"+                            , "license:            BSD-3-Clause"+                            , ""+                            , "library"+                            , "    build-depends:    base"+                            , "    default-language: Haskell2010"+                            ]+            , runCabalTestCaseSession "Apache-2.0" "" $ do+                doc <- openDoc "licenseCodeAction2.cabal" "cabal"+                diags <- waitForDiagnosticsFromSource doc "cabal"+                -- test if it supports typos in license name, here 'apahe'+                reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"]+                liftIO $ do+                    length diags @?= 1+                    reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0)+                    reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error+                [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0))+                executeCodeAction codeAction+                contents <- documentContents doc+                liftIO $+                    contents+                        @?= Text.unlines+                            [ "cabal-version:      3.0"+                            , "name:               licenseCodeAction2"+                            , "version:            0.1.0.0"+                            , "license:            Apache-2.0"+                            , ""+                            , "library"+                            , "    build-depends:    base"+                            , "    default-language: Haskell2010"+                            ]+            ]+        ]+  where+    getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction]+    getLicenseAction license codeActions = do+        InR action@CodeAction{_title} <- codeActions+        guard (_title == "Replace with " <> license)+        pure action
+ plugins/hls-cabal-plugin/test/Utils.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings        #-}++module Utils where++import           Data.List                         (sort)+import qualified Data.Text                         as T+import           Ide.Plugin.Cabal                  (descriptor)+import qualified Ide.Plugin.Cabal+import           Ide.Plugin.Cabal.Completion.Types+import           System.FilePath+import           Test.Hls++cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log+cabalPlugin = mkPluginTestDescriptor descriptor "cabal"++simpleCabalPrefixInfoFromPos :: Position -> T.Text -> CabalPrefixInfo+simpleCabalPrefixInfoFromPos pos prefix =+    CabalPrefixInfo+        { completionPrefix = prefix+        , completionCursorPosition = pos+        , isStringNotation = Nothing+        , completionRange = Range pos (Position 0 0)+        , completionWorkingDir = ""+        , completionFileName = "test"+        }++simpleCabalPrefixInfoFromFp :: T.Text -> FilePath -> CabalPrefixInfo+simpleCabalPrefixInfoFromFp prefix fp =+    CabalPrefixInfo+        { completionPrefix = prefix+        , isStringNotation = Nothing+        , completionCursorPosition = Position 0 0+        , completionRange = Range (Position 0 0) (Position 0 0)+        , completionWorkingDir = fp+        , completionFileName = "test"+        }++filePathComplTestDir :: FilePath+filePathComplTestDir = addTrailingPathSeparator $ testDataDir </> "filepath-completions"++runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree+runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir++runCabalSession :: FilePath -> Session a -> IO a+runCabalSession subdir =+    failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir </> subdir)++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-cabal-plugin" </> "test" </> "testdata"++-- | list comparison where the order in the list is irrelevant+(@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion+(@?==) l1 l2 = sort l1 @?= sort l2
+ plugins/hls-cabal-plugin/test/testdata/completer.cabal view
@@ -0,0 +1,12 @@+cabal-version: 3.4+name:          test-hls+version:       0.1.0.0+maintainer:    milky+synopsis:      example cabal file :)+license:       Apache-2.0+build-type:    Simple++be++library+    lib
+ plugins/hls-cabal-plugin/test/testdata/exposed.cabal view
@@ -0,0 +1,40 @@+cabal-version: 3.4+name:          test-hls+version:       0.1.0.0+maintainer:    milky+category:      Dev+synopsis:      dsasd+license:       MIT+license-file:  ./LICENSE.md++library+  hs-source-dirs:   ./src-modules/Dir1/+  exposed-modules:+  build-depends:    base+  default-language: Haskell2010++benchmark benchie+  type: exitcode-stdio-1.0+  main-is: Main.hs+  build-depends: base+  hs-source-dirs: ./src-modules/+  exposed-modules:++executable executie+  main-is: Main.hs+  build-depends: base+  hs-source-dirs: ./src-modules/ ./src-modules/Dir1/+  exposed-modules:++executable exe-not-so-cutie+  main-is: Main.hs+  build-depends: base+  hs-source-dirs: ./src-modules/Dir1/Dir2/ ./src-modules/Dir1/Dir3+  exposed-modules:++test-suite suitor+  type: exitcode-stdio-1.0+  main-is: Main.hs+  build-depends: base+  hs-source-dirs: "./src-modules/Dir1/Dir3/Dir4"+  exposed-modules:
+ plugins/hls-cabal-plugin/test/testdata/filepath-completions/Content.hs view
+ plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f1.txt view
@@ -0,0 +1,1 @@+test text file
+ plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f2.hs view
@@ -0,0 +1,1 @@+-- test haskell file
+ plugins/hls-cabal-plugin/test/testdata/filepath-completions/main-is.cabal view
@@ -0,0 +1,11 @@+cabal-version: 3.4+name:          test-hls+version:       0.1.0.0+maintainer:    milky+synopsis:      example cabal file :)+license:       Apache-2.0+build-type:    Simple++executable exe+    hs-source-dirs: ./dir1/+    main-is:
+ plugins/hls-cabal-plugin/test/testdata/filepath-completions/textfile.txt view
@@ -0,0 +1,1 @@+test text file
+ plugins/hls-cabal-plugin/test/testdata/invalid.cabal view
@@ -0,0 +1,8 @@+cabal-version:      3.0+name:               invalid+version:            0.1.0.0+license:            BSD3++library+    build-depends:    base+    default-language: Haskell2010
+ plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal view
@@ -0,0 +1,8 @@+cabal-version:      3.0+name:               licenseCodeAction+version:            0.1.0.0+license:            BSD3++library+    build-depends:    base+    default-language: Haskell2010
+ plugins/hls-cabal-plugin/test/testdata/licenseCodeAction2.cabal view
@@ -0,0 +1,8 @@+cabal-version:      3.0+name:               licenseCodeAction2+version:            0.1.0.0+license:            APAHE++library+    build-depends:    base+    default-language: Haskell2010
+ plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs view
@@ -0,0 +1,4 @@+module A where++-- definitions don't matter here.+foo = 1
+ plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+  cabal:
+ plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal view
@@ -0,0 +1,10 @@+cabal-version:      3.0+name:               simple-cabal+version:            0.1.0.0+license:            MIT++library+    build-depends:    base+    hs-source-dirs:   .+    exposed-modules:  A+    default-language: Haskell2010
+ plugins/hls-cabal-plugin/test/testdata/simple.cabal view
@@ -0,0 +1,24 @@+cabal-version:      3.0+name:               hls-cabal-plugin+version:            0.1.0.0+synopsis:+homepage:+license:            MIT+license-file:       LICENSE+author:             Fendor+maintainer:         fendor@posteo.de+category:           Development+extra-source-files: CHANGELOG.md++library+    exposed-modules:  IDE.Plugin.Cabal+    build-depends:    base ^>=4.14.3.0+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite hls-cabal-plugin-test+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:    base ^>=4.14.3.0
+ plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir2/File2.hs view
+ plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir3/Dir4/File3.hs view
+ plugins/hls-cabal-plugin/test/testdata/src-modules/File1.hs view
+ plugins/hls-cabal-plugin/test/testdata/src-modules/test.cabal view
+ plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.CallHierarchy (descriptor) where++import           Development.IDE+import qualified Ide.Plugin.CallHierarchy.Internal as X+import           Ide.Types+import           Language.LSP.Protocol.Message++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId "Provides call-hierarchy support in Haskell")+    { Ide.Types.pluginHandlers =+        mkPluginHandler SMethod_TextDocumentPrepareCallHierarchy X.prepareCallHierarchy+     <> mkPluginHandler SMethod_CallHierarchyIncomingCalls X.incomingCalls+     <> mkPluginHandler SMethod_CallHierarchyOutgoingCalls X.outgoingCalls+    }
+ plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Ide.Plugin.CallHierarchy.Internal (+  prepareCallHierarchy+, incomingCalls+, outgoingCalls+) where++import           Control.Lens                   (Lens', (^.))+import           Control.Monad.IO.Class+import           Data.Aeson                     as A+import           Data.Functor                   ((<&>))+import           Data.List                      (groupBy, sortBy)+import qualified Data.Map                       as M+import           Data.Maybe+import           Data.Ord                       (comparing)+import qualified Data.Set                       as S+import qualified Data.Text                      as T+import           Data.Tuple.Extra+import           Development.IDE+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat     as Compat+import           Development.IDE.Spans.AtPoint+import           HieDb                          (Symbol (Symbol))+import qualified Ide.Plugin.CallHierarchy.Query as Q+import           Ide.Plugin.CallHierarchy.Types+import           Ide.Plugin.Error+import           Ide.Types+import qualified Language.LSP.Protocol.Lens     as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Prelude                        hiding (mod, span)+import           Text.Read                      (readMaybe)++-- | Render prepare call hierarchy request.+prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy+prepareCallHierarchy state _ param = do+    nfp <- getNormalizedFilePathE (param ^. (L.textDocument . L.uri))+    items <- liftIO+        $ runAction "CallHierarchy.prepareHierarchy" state+        $ prepareCallHierarchyItem nfp (param ^. L.position)+    pure $ InL items++prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]+prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case+    Nothing               -> mempty+    Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp++prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]+prepareByAst hf pos nfp =+    case listToMaybe $ pointCommand hf pos extract of+        Nothing    -> mempty+        Just infos -> mapMaybe (construct nfp hf) infos++extract :: HieAST a -> [(Identifier, [ContextInfo], Span)]+extract ast = let span = nodeSpan ast+                  infos = M.toList $ M.map (S.toList . identInfo) (Compat.getNodeIds ast)+              in  [(ident, contexts, span) | (ident, contexts) <- infos]++recFieldInfo, declInfo, valBindInfo, classTyDeclInfo,+    useInfo, patternBindInfo, tyDeclInfo, matchBindInfo :: [ContextInfo] -> Maybe ContextInfo+recFieldInfo    ctxs = listToMaybe [ctx       | ctx@RecField{}    <- ctxs]+declInfo        ctxs = listToMaybe [ctx       | ctx@Decl{}        <- ctxs]+valBindInfo     ctxs = listToMaybe [ctx       | ctx@ValBind{}     <- ctxs]+classTyDeclInfo ctxs = listToMaybe [ctx       | ctx@ClassTyDecl{} <- ctxs]+useInfo         ctxs = listToMaybe [Use       | Use               <- ctxs]+patternBindInfo ctxs = listToMaybe [ctx       | ctx@PatternBind{} <- ctxs]+tyDeclInfo      ctxs = listToMaybe [TyDecl    | TyDecl            <- ctxs]+matchBindInfo   ctxs = listToMaybe [MatchBind | MatchBind         <- ctxs]++construct :: NormalizedFilePath -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem+construct nfp hf (ident, contexts, ssp)+    | isInternalIdentifier ident = Nothing++    | Just (RecField RecFieldDecl _) <- recFieldInfo contexts+        -- ignored type span+        = Just $ mkCallHierarchyItem' ident SymbolKind_Field ssp ssp++    | isJust (matchBindInfo contexts) && isNothing (valBindInfo contexts)+        = Just $ mkCallHierarchyItem' ident SymbolKind_Function ssp ssp++    | Just ctx <- valBindInfo contexts+        = Just $ case ctx of+            ValBind _ _ span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp+            _                -> mkCallHierarchyItem' ident skUnknown ssp ssp++    | Just ctx <- declInfo contexts+        = Just $ case ctx of+            Decl ClassDec span -> mkCallHierarchyItem' ident SymbolKind_Interface     (renderSpan span) ssp+            Decl ConDec   span -> mkCallHierarchyItem' ident SymbolKind_Constructor   (renderSpan span) ssp+            Decl DataDec  span -> mkCallHierarchyItem' ident SymbolKind_Struct        (renderSpan span) ssp+            Decl FamDec   span -> mkCallHierarchyItem' ident SymbolKind_Function      (renderSpan span) ssp+            Decl InstDec  span -> mkCallHierarchyItem' ident SymbolKind_Interface     (renderSpan span) ssp+            Decl SynDec   span -> mkCallHierarchyItem' ident SymbolKind_TypeParameter (renderSpan span) ssp+            _ -> mkCallHierarchyItem' ident skUnknown ssp ssp++    | Just (ClassTyDecl span) <- classTyDeclInfo contexts+        = Just $ mkCallHierarchyItem' ident SymbolKind_Method (renderSpan span) ssp++    | Just (PatternBind _ _ span) <- patternBindInfo contexts+        = Just $ mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp++    | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SymbolKind_Interface ssp ssp++    | Just _ <- tyDeclInfo contexts = renderTyDecl++    | otherwise = Nothing+    where+        renderSpan (Just span) = span+        renderSpan _           = ssp++        -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97+        -- There is no longer an unknown symbol, thus using SymbolKind_Function+        -- as this is the call-hierarchy plugin+        skUnknown = SymbolKind_Function++        mkCallHierarchyItem' = mkCallHierarchyItem nfp++        isInternalIdentifier = \case+            Left _     -> False+            Right name -> isInternalName name++        renderTyDecl = case ident of+            Left _ -> Nothing+            Right name -> case getNameBinding name (getAsts hf) of+                Nothing -> Nothing+                Just sp -> listToMaybe $ prepareByAst hf (realSrcSpanToRange sp ^. L.start) nfp++mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem+mkCallHierarchyItem nfp ident kind span selSpan =+    CallHierarchyItem+        (T.pack $ optimizeDisplay $ identifierName ident)+        kind+        Nothing+        (Just $ T.pack $ identifierToDetail ident)+        (fromNormalizedUri $ normalizedFilePathToUri nfp)+        (realSrcSpanToRange span)+        (realSrcSpanToRange selSpan)+        (toJSON . show <$> mkSymbol ident)+    where+        identifierToDetail :: Identifier -> String+        identifierToDetail = \case+            Left modName -> moduleNameString modName+            Right name   -> (moduleNameString . moduleName . nameModule) name++        identifierName :: Identifier -> String+        identifierName = \case+            Left modName -> moduleNameString modName+            Right name   -> occNameString $ nameOccName name++        optimizeDisplay :: String -> String+        optimizeDisplay name -- Optimize display for DuplicateRecordFields+            | "$sel:" == take 5 name = drop 5 name+            | otherwise = name++mkSymbol :: Identifier -> Maybe Symbol+mkSymbol = \case+    Left _     -> Nothing+    Right name -> Just $ Symbol (occName name) (nameModule name)++----------------------------------------------------------------------+-------------- Incoming calls and outgoing calls ---------------------+----------------------------------------------------------------------++-- | Render incoming calls request.+incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls+incomingCalls state _pluginId param = do+    calls <- liftIO+        $ runAction "CallHierarchy.incomingCalls" state+        $ queryCalls+            (param ^. L.item)+            Q.incomingCalls+            mkCallHierarchyIncomingCall+            (mergeCalls CallHierarchyIncomingCall L.from)+    pure $ InL calls+    where+        mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)+        mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall++-- | Render outgoing calls request.+outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls+outgoingCalls state _pluginId param = do+    calls <- liftIO+        $ runAction "CallHierarchy.outgoingCalls" state+        $ queryCalls+            (param ^. L.item)+            Q.outgoingCalls+            mkCallHierarchyOutgoingCall+            (mergeCalls CallHierarchyOutgoingCall L.to)+    pure $ InL calls+    where+        mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)+        mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall++-- | Merge calls from the same place+mergeCalls ::+    L.HasFromRanges s [Range]+    => (CallHierarchyItem -> [Range] -> s)+    -> Lens' s CallHierarchyItem+    -> [s]+    -> [s]+mergeCalls constructor target =+    concatMap merge+        . groupBy (\a b -> a ^. target == b ^. target)+        . sortBy (comparing (^. target))+    where+        merge [] = []+        merge calls@(call:_) =+            let ranges = concatMap (^. L.fromRanges) calls+            in  [constructor (call ^. target) ranges]++mkCallHierarchyCall :: (CallHierarchyItem ->  [Range] -> a) -> Vertex -> Action (Maybe a)+mkCallHierarchyCall mk v@Vertex{..} = do+    let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1)+        nfp = toNormalizedFilePath' hieSrc+        range = mkRange+                    (fromIntegral $ casl - 1)+                    (fromIntegral $ casc - 1)+                    (fromIntegral $ cael - 1)+                    (fromIntegral $ caec - 1)++    prepareCallHierarchyItem nfp pos >>=+        \case+            [item] -> pure $ Just $ mk item [range]+            _      -> do+                ShakeExtras{withHieDb} <- getShakeExtras+                sps <- liftIO (withHieDb (`Q.getSymbolPosition` v))+                case sps of+                    (x:_) -> do+                        items <- prepareCallHierarchyItem+                                    nfp+                                    (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1))+                        case items of+                            [item] -> pure $ Just $ mk item [range]+                            _      -> pure Nothing+                    []     -> pure Nothing++-- | Unified queries include incoming calls and outgoing calls.+queryCalls ::+    CallHierarchyItem+    -> (HieDb -> Symbol -> IO [Vertex])+    -> (Vertex -> Action (Maybe a))+    -> ([a] -> [a])+    -> Action [a]+queryCalls item queryFunc makeFunc merge+    | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do+        ShakeExtras{withHieDb} <- getShakeExtras+        maySymbol <- getSymbol nfp+        case maySymbol of+            Nothing -> pure mempty+            Just symbol -> do+                vs <- liftIO $ withHieDb (`queryFunc` symbol)+                items <- catMaybes <$> mapM makeFunc vs+                pure $ merge items+    | otherwise = pure mempty+    where+        uri = item ^. L.uri+        pos = item ^. (L.selectionRange . L.start)++        getSymbol nfp = case item ^. L.data_ of+            Just xdata -> case fromJSON xdata of+                A.Success (symbolStr :: String) -> maybe (getSymbolFromAst nfp pos) (pure . pure) $ readMaybe symbolStr+                A.Error _ -> getSymbolFromAst nfp pos+            Nothing -> getSymbolFromAst nfp pos -- Fallback if xdata lost, some editor(VSCode) will drop it++        getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol)+        getSymbolFromAst nfp pos_ = use GetHieAst nfp <&> \case+            Nothing -> Nothing+            Just (HAR _ hf _ _ _) -> do+                case listToMaybe $ pointCommand hf pos_ extract of+                    Just infos -> mkSymbol . fst3 =<< listToMaybe infos+                    Nothing    -> Nothing
+ plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns    #-}++module Ide.Plugin.CallHierarchy.Query (+  incomingCalls+, outgoingCalls+, getSymbolPosition+) where++import qualified Data.Text                      as T+import           Database.SQLite.Simple+import           Development.IDE.GHC.Compat+import           HieDb                          (HieDb (getConn), Symbol (..))+import           Ide.Plugin.CallHierarchy.Types+import           Prelude                        hiding (mod)++incomingCalls :: HieDb -> Symbol -> IO [Vertex]+incomingCalls (getConn -> conn) symbol = do+    let (o, m, u) = parseSymbol symbol+    query conn+        (Query $ T.pack $ concat+            [ "SELECT mods.mod, decls.occ, mods.hs_src, decls.sl, decls.sc, "+            , "decls.el, decls.ec, refs.sl, refs.sc, refs.el, refs.ec "+            , "FROM refs "+            , "JOIN decls ON decls.hieFile = refs.hieFile "+            , "JOIN mods ON mods.hieFile = decls.hieFile "+            , "where "+            , "(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) "+            , "AND "+            , "(decls.occ != ? OR mods.mod != ? OR mods.unit != ?) "+            , "AND "+            , "((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) "+            , "AND "+            ,"((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))"+            ]+        ) (o, m, u, o, m, u)++outgoingCalls :: HieDb -> Symbol -> IO [Vertex]+outgoingCalls (getConn -> conn) symbol = do+    let (o, m, u) = parseSymbol symbol+    query conn+        (Query $ T.pack $ concat+            [ "SELECT rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, "+            , "refs.sl, refs.sc, refs.el, refs.ec "+            , "from refs "+            , "JOIN defs ON defs.occ = refs.occ "+            , "JOIN decls rd ON rd.hieFile = defs.hieFile AND rd.occ = defs.occ "+            , "JOIN mods rm ON rm.mod = refs.mod AND rm.unit = refs.unit AND rm.hieFile = defs.hieFile "+            , "JOIN decls ON decls.hieFile = refs.hieFile "+            , "JOIN mods ON mods.hieFile = decls.hieFile "+            , "where "+            , "(decls.occ = ? AND mods.mod = ? AND mods.unit = ?) "+            , "AND "+            , "(defs.occ != ? OR rm.mod != ? OR rm.unit != ?) "+            , "AND "+            , "((refs.sl = decls.sl AND refs.sc >  decls.sc) OR (refs.sl > decls.sl)) "+            , "AND "+            , "((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))"+            ]+        ) (o, m, u, o, m, u)++getSymbolPosition :: HieDb -> Vertex -> IO [SymbolPosition]+getSymbolPosition (getConn -> conn) Vertex{..} = do+    query conn+        (Query $ T.pack $ concat+            [ "SELECT refs.sl, refs.sc from refs where "+            , "(occ = ?) "+            , "AND "+            , "((refs.sl = ? AND refs.sc > ?) OR (refs.sl > ?)) "+            , "AND "+            , "((refs.el = ? AND refs.ec <= ?) OR (refs.el < ?))"+            ]+        ) (occ, sl, sc, sl, el, ec, el)++parseSymbol :: Symbol -> (OccName, ModuleName, Unit)+parseSymbol Symbol{..} =+    let o = symName+        m = moduleName symModule+        u = moduleUnit symModule+    in  (o, m, u)
+ plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Ide.Plugin.CallHierarchy.Types where++import           Data.Aeson+import           Database.SQLite.Simple+import           Database.SQLite.Simple.ToField+import           GHC.Generics++data Vertex = Vertex {+  mod    :: String+, occ    :: String+, hieSrc :: FilePath+, sl     :: Int -- ^ start line+, sc     :: Int -- ^ start character+, el     :: Int -- ^ end line+, ec     :: Int -- ^ end character+, casl   :: Int -- ^ sl for call appear+, casc   :: Int -- ^ sc for call appear+, cael   :: Int -- ^ el for call appear+, caec   :: Int -- ^ ec for call appear+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++instance ToRow Vertex where+    toRow (Vertex a b c d e f g h i j k) =+        [ toField a, toField b, toField c, toField d+        , toField e, toField f, toField g, toField h+        , toField i, toField j, toField k+        ]++instance FromRow Vertex where+    fromRow = Vertex <$> field <*> field <*> field+                     <*> field <*> field <*> field+                     <*> field <*> field <*> field+                     <*> field <*> field++data SymbolPosition = SymbolPosition {+  psl :: Int+, psc :: Int+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++instance ToRow SymbolPosition where+    toRow (SymbolPosition a b) = toRow (a, b)++instance FromRow SymbolPosition where+    fromRow = SymbolPosition <$> field <*> field
+ plugins/hls-call-hierarchy-plugin/test/Main.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import           Control.Lens               (set, (^.))+import           Control.Monad.Extra+import qualified Data.Aeson                 as Aeson+import           Data.Functor               ((<&>))+import           Data.List                  (sort, tails)+import qualified Data.Map                   as M+import qualified Data.Text                  as T+import           Development.IDE.Test+import           Ide.Plugin.CallHierarchy+import qualified Language.LSP.Protocol.Lens as L+import qualified Language.LSP.Test          as Test+import           System.FilePath+import           Test.Hls++plugin :: PluginTestDescriptor ()+plugin = mkPluginTestDescriptor' descriptor "call-hierarchy"++main :: IO ()+main = defaultTestRunner $+  testGroup "Call Hierarchy"+    [ prepareCallHierarchyTests+    , incomingCallsTests+    , outgoingCallsTests+    ]++prepareCallHierarchyTests :: TestTree+prepareCallHierarchyTests =+  testGroup+  "Prepare Call Hierarchy"+  [ testCase "variable" $ do+      let contents = T.unlines ["a=3"]+          range = mkRange 0 0 0 3+          selRange = mkRange 0 0 0 1+          expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange+      oneCaseWithCreate contents 0 0 expected+  , testCase "function" $ do+      let contents = T.unlines ["a=(+)"]+          range = mkRange 0 0 0 5+          selRange = mkRange 0 0 0 1+          expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange+      oneCaseWithCreate contents 0 0 expected+  , testCase "datatype" $ do+      let contents = T.unlines ["data A=A"]+          range = mkRange 0 0 0 8+          selRange = mkRange 0 5 0 6+          expected = mkCallHierarchyItemT "A" SymbolKind_Struct range selRange+      oneCaseWithCreate contents 0 5 expected+  , testCase "data constructor" $ do+      let contents = T.unlines ["data A=A"]+          range = mkRange 0 7 0 8+          selRange = mkRange 0 7 0 8+          expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange+      oneCaseWithCreate contents 0 7 expected+--   , testCase "record" $ do+--       let contents = T.unlines ["data A=A{a::Int}"]+--           range = mkRange 0 9 0 10+--           selRange = mkRange 0 9 0 10+--           expected = mkCallHierarchyItemV "a" SymbolKind_Field range selRange+--       oneCaseWithCreate contents 0 9 expected+  , testCase "type operator" $ do+      let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"]+          range = mkRange 1 0 1 15+          selRange = mkRange 1 5 1 9+          expected = mkCallHierarchyItemT "><" SymbolKind_TypeParameter range selRange+      oneCaseWithCreate contents 1 5 expected+  , testCase "type class" $ do+      let contents = T.unlines ["class A a where a :: a -> Int"]+          range = mkRange 0 0 0 29+          selRange = mkRange 0 6 0 7+          expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange+      oneCaseWithCreate contents 0 6 expected+  , testCase "type class method" $ do+      let contents = T.unlines ["class A a where a :: a -> Int"]+          range = mkRange 0 16 0 29+          selRange = mkRange 0 16 0 17+          expected = mkCallHierarchyItemV "a" SymbolKind_Method range selRange+      oneCaseWithCreate contents 0 16 expected+  , testCase "type class instance" $ do+      let contents = T.unlines ["class A a where", "instance A () where"]+          range = mkRange 1 9 1 10+          selRange = mkRange 1 9 1 10+          expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange+      oneCaseWithCreate contents 1 9 expected+  , testGroup "type family"+      [ testCase "1" $ do+          let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"]+              range = mkRange 1 0 1 13+              selRange = mkRange 1 12 1 13+              expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange+          oneCaseWithCreate contents 1 12 expected+      , testCase "2" $ do+          let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"]+              range = mkRange 1 0 1 15+              selRange = mkRange 1 12 1 13+              expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange+          oneCaseWithCreate contents 1 12 expected+      ]+  , testCase "type family instance" $ do+      let contents = T.unlines+            [ "{-# LANGUAGE TypeFamilies #-}"+            , "type family A a"+            , "type instance A () = ()"+            ]+          range = mkRange 2 14 2 23+          selRange = mkRange 2 14 2 15+          expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange+      oneCaseWithCreate contents 2 14 expected+  , testGroup "data family"+      [ testCase "1" $ do+          let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"]+              range = mkRange 1 0 1 11+              selRange = mkRange 1 12 1 13+              expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange+          oneCaseWithCreate contents 1 12 expected+      , testCase "2" $ do+          let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"]+              range = mkRange 1 0 1 11+              selRange = mkRange 1 12 1 13+              expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange+          oneCaseWithCreate contents 1 12 expected+      ]+  , testCase "data family instance" $ do+      let contents = T.unlines+            [ "{-# LANGUAGE TypeFamilies #-}"+            , "data family A a"+            , "data instance A () = A()"+            ]+          range = mkRange 2 14 2 24+          selRange = mkRange 2 14 2 15+          expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange+      oneCaseWithCreate contents 2 14 expected+  , testCase "pattern" $ do+      let contents = T.unlines ["Just x = Just 3"]+          range = mkRange 0 0 0 15+          selRange = mkRange 0 5 0 6+          expected = mkCallHierarchyItemV "x" SymbolKind_Function range selRange+      oneCaseWithCreate contents 0 5 expected+  , testCase "pattern with type signature" $ do+      let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"]+          range = mkRange 1 0 1 12+          selRange = mkRange 1 0 1 1+          expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange+      oneCaseWithCreate contents 1 0 expected+  , testCase "type synonym" $ do+      let contents = T.unlines ["type A=Bool"]+          range = mkRange 0 0 0 11+          selRange = mkRange 0 5 0 6+          expected = mkCallHierarchyItemT "A" SymbolKind_TypeParameter range selRange+      oneCaseWithCreate contents 0 5 expected+  , testCase "GADT" $ do+      let contents = T.unlines+            [ "{-# LANGUAGE GADTs #-}"+            , "data A where A :: Int -> A"+            ]+          range = mkRange 1 13 1 26+          selRange = mkRange 1 13 1 14+          expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange+      oneCaseWithCreate contents 1 13 expected+  , testGroup "type signature"+      [ testCase "next line" $ do+          let contents = T.unlines ["a::Int", "a=3"]+              range = mkRange 1 0 1 3+              selRange = mkRange 1 0 1 1+              expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange+          oneCaseWithCreate contents 0 0 expected+      , testCase "multi functions" $ do+          let contents = T.unlines [ "a,b::Int", "a=3", "b=4"]+              range = mkRange 2 0 2 3+              selRange = mkRange 2 0 2 1+              expected = mkCallHierarchyItemV "b" SymbolKind_Function range selRange+          oneCaseWithCreate contents 0 2 expected+      ]+  , testCase "multi pattern" $ do+      let contents = T.unlines+            [ "f (Just _) = ()"+            , "f Nothing = ()"+            ]+          range = mkRange 1 0 1 1+          selRange = mkRange 1 0 1 1+          expected = mkCallHierarchyItemV "f" SymbolKind_Function range selRange+      oneCaseWithCreate contents 1 0 expected+  ]++incomingCallsTests :: TestTree+incomingCallsTests =+  testGroup "Incoming Calls"+  [ testGroup "single file"+    [ testCase "xdata unavailable" $+        runSessionWithServer def plugin testDataDir $ do+          doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]+          waitForIndex (testDataDir </> "A.hs")+          item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)+          let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]]+          item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0)+          let itemNoData = set L.data_ Nothing item'+          res <- Test.incomingCalls (mkIncomingCallsParam itemNoData)+          liftIO $ sort expected @=? sort res+          closeDoc doc+    , testCase "xdata available" $ do+        let contents = T.unlines ["a=3","b=a"]+            positions = [(1, 0)]+            ranges = [mkRange 1 2 1 3]+        incomingCallTestCase contents 0 1 positions ranges+    , testGroup "data"+      [ testCase "data type" $ do+          let contents = T.unlines ["data A=A"]+              positions = []+              ranges = []+          incomingCallTestCase contents 0 5 positions ranges+      , testCase "data constructor" $ do+          let contents = T.unlines ["data A=A"]+              positions = [(0, 5)]+              ranges = [mkRange 0 7 0 8]+          incomingCallTestCase contents 0 7 positions ranges+    --   , testCase "record" $ do+    --       let contents = T.unlines ["data A=A{a::Int}"]+    --           positions = [(0, 5), (0, 7)]+    --           ranges = [mkRange 0 9 0 10, mkRange 0 9 0 10]+    --       incomingCallTestCase contents 0 9 positions ranges+      ]+    , testCase "function" $ do+        let contents = T.unlines ["a=(+)"]+            positions = [(0, 0)]+            ranges = [mkRange 0 2 0 5]+        incomingCallTestCase contents 0 3 positions ranges+    , testCase "type operator" $ do+        let contents = T.unlines+              [ "{-# LANGUAGE TypeOperators #-}"+              , "type (><)=Int"]+            positions = [(1, 5)]+            ranges = [mkRange 1 10 1 13]+        incomingCallTestCase contents 1 10 positions ranges+    , testGroup "type class"+      [ testCase "type class method" $ do+          let contents = T.unlines ["class A a where a :: a -> Int"]+              positions = [(0, 6)]+              ranges = [mkRange 0 16 0 17]+          incomingCallTestCase contents 0 16 positions ranges+      , testCase "type class instance" $ do+          let contents = T.unlines+                [ "class A a where a :: a -> Int"+                , "instance A () where a = const 3"]+              positions = [(0, 6)]+              ranges = [mkRange 0 16 0 17]+          incomingCallTestCase contents 1 20 positions ranges+      , testCase "goto typeclass instance" $ do+          let contents = T.unlines+                [ "class F a where f :: a"+                , "instance F Bool where f = x"+                , "instance F Int where f = 3"+                , "x = True"+                ]+              positions = [(1, 22)]+              ranges = [mkRange 1 26 1 27]+          incomingCallTestCase contents 3 0 positions ranges+      ]+    , testCase "type family instance" $ do+        let contents = T.unlines+              [ "{-# LANGUAGE TypeFamilies #-}"+              , "type family A a"+              , "type instance A Int = Char"+              ]+            positions = [(2, 14)]+            ranges = [mkRange 2 22 2 26]+        incomingCallTestCase contents 2 22 positions ranges+    , testCase "GADT" $ do+        let contents = T.unlines+              [ "{-# LANGUAGE GADTs #-}"+              , "data A where B :: Int -> A"+              ]+            positions = [(1, 5)]+            ranges = [mkRange 1 13 1 14]+        incomingCallTestCase contents 1 13 positions ranges+    , testCase "multi pattern" $ do+        let contents = T.unlines+                [ "f 1 = 1"+                , "f 2 = 2"+                , "g = f"+                ]+            positions = [(2, 0)]+            ranges = [mkRange 2 4 2 5]+        incomingCallTestCase contents 1 0 positions ranges+    ]+  , testGroup "multi file"+    [ testCase "1" $ do+        let mp = M.fromList [+                  ("A.hs", [ ((5, 0), mkRange 5 7 5 11)+                           , ((6, 0), mkRange 6 7 6 11)+                           , ((8, 0), mkRange 9 25 9 29)+                           ]+                  )]+        incomingCallMultiFileTestCase "A.hs" 4 0 mp+    , testCase "2" $ do+        let mp = M.fromList [+                  ("A.hs", [ ((4, 0), mkRange 4 13 4 16)+                           , ((8, 0), mkRange 10 7 10 10)+                           ]+                  )+                , ("B.hs", [ ((4, 0), mkRange 4 8 4 11)])+                ]+        incomingCallMultiFileTestCase "C.hs" 2 0 mp+    ]+  ]++outgoingCallsTests :: TestTree+outgoingCallsTests =+  testGroup "Outgoing Calls"+  [ testGroup "single file"+    [ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir ->+        runSessionWithServer def plugin dir $ do+          doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]+          waitForIndex (dir </> "A.hs")+          item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1)+          let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]]+          item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)+          let itemNoData = set L.data_ Nothing item'+          res <- Test.outgoingCalls (mkOutgoingCallsParam itemNoData)+          liftIO $ sort expected @=? sort res+          closeDoc doc+    , testCase "xdata available" $ do+        let contents = T.unlines ["a=3", "b=a"]+            positions = [(0, 0)]+            ranges = [mkRange 1 2 1 3]+        outgoingCallTestCase contents 1 0 positions ranges+    , testGroup "data"+      [ testCase "data type" $ do+          let contents = T.unlines ["data A=A"]+              positions = [(0, 7)]+              ranges = [mkRange 0 7 0 8]+          outgoingCallTestCase contents 0 5 positions ranges+      , testCase "data constructor" $ do+          let contents = T.unlines ["data A=A"]+              positions = []+              ranges = []+          outgoingCallTestCase contents 0 7 positions ranges+    --   , testCase "record" $ do+    --       let contents = T.unlines ["data A=A{a::Int}"]+    --           positions = [(0, 7), (0, 9)]+    --           ranges = [mkRange 0 7 0 8, mkRange 0 9 0 10]+    --       outgoingCallTestCase contents 0 5 positions ranges+      ]+      , testCase "function" $ do+          let contents = T.unlines ["a=3", "b=4", "c=a+b"]+              positions = [(0, 1), (1, 1)]+              ranges = [mkRange 2 2 2 3, mkRange 2 4 2 5]+          outgoingCallTestCase contents 2 0 positions ranges+      , testCase "type synonym" $ do+          let contents = T.unlines ["data A", "type B=A"]+              positions = [(0, 5)]+              ranges = [mkRange 1 7 1 8]+          outgoingCallTestCase contents 1 5 positions ranges+      , testCase "type class instance" $ do+          let contents = T.unlines+                [ "class A a where a :: a"+                , "instance A () where a = ()"+                ]+              positions = [(0, 16)]+              ranges = [mkRange 0 16 0 17]+          outgoingCallTestCase contents 1 9 positions ranges+      , testCase "data family instance" $ do+          let contents = T.unlines+                [ "{-# LANGUAGE TypeFamilies #-}"+                , "data family A a"+                , "data instance A () = B"+                ]+              positions = [(2, 21)]+              ranges = [mkRange 2 21 2 22]+          outgoingCallTestCase contents 1 12 positions ranges+      , testCase "GADT" $ do+          let contents = T.unlines ["{-# LANGUAGE GADTs #-}", "data A where B :: A"]+              positions = [(1, 13)]+              ranges = [mkRange 1 13 1 14]+          outgoingCallTestCase contents 1 5 positions ranges+    ]+  , testGroup "multi file"+    [ testCase "1" $ do+        let mp = M.fromList [+                  ("A.hs", [ ((4, 0), mkRange 5 7 5 11)])+                , ("B.hs", [ ((4, 0), mkRange 5 14 5 17)])+                , ("C.hs", [ ((3, 0), mkRange 5 20 5 23)])+                ]+        outgoingCallMultiFileTestCase "A.hs" 5 0 mp+    , testCase "2" $ do+        let mp = M.fromList [+                  ("A.hs", [ ((4, 0), mkRange 9 25 9 29)+                           , ((5, 0), mkRange 10 25 10 29)+                           ]+                  )+                , ("B.hs", [ ((2, 9), mkRange 9 2 9 3)+                           , ((2, 13), mkRange 10 2 10 3)+                           , ((4, 0), mkRange 9 7 9 10)+                           , ((5, 0), mkRange 9 13 9 16)+                           , ((6, 0), mkRange 9 19 9 22)+                           ]+                  )+                , ("C.hs", [ ((2, 0), mkRange 10 7 10 10)+                           , ((3, 0), mkRange 10 13 10 16)+                           , ((4, 0), mkRange 10 19 10 22)+                           ]+                  )+                ]+        outgoingCallMultiFileTestCase "A.hs" 8 0 mp+    ]+  ]+++incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion+incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->+  runSessionWithServer def plugin dir $ do+    doc <- createDoc "A.hs" "haskell" contents+    waitForIndex (dir </> "A.hs")+    items <- concatMapM (\((x, y), range) ->+      Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y)+          <&> map (, range)+      )+      (zip positions ranges)+    let expected = map mkCallHierarchyIncomingCall items+    item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)+    res <- Test.incomingCalls (mkIncomingCallsParam item)+    liftIO $ sort expected @=? sort res+    closeDoc doc++incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion+incomingCallMultiFileTestCase filepath queryX queryY mp =+  runSessionWithServer def plugin testDataDir $ do+    doc <- openDoc filepath "haskell"+    waitForIndex (testDataDir </> filepath)+    items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do+              p <- openDoc fp "haskell"+              waitForKickDone+              concatMapM (\((x, y), range) ->+                  Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y)+                    <&> map (, range)+                ) pr) mp+    let expected = map mkCallHierarchyIncomingCall items+    item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)+    res <- Test.incomingCalls (mkIncomingCallsParam item)+    liftIO $ sort expected @=? sort res+    closeDoc doc++outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion+outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->+  runSessionWithServer def plugin dir $ do+    doc <- createDoc "A.hs" "haskell" contents+    waitForIndex (dir </> "A.hs")+    items <- concatMapM (\((x, y), range) ->+      Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y)+          <&> map (, range)+      )+      (zip positions ranges)+    let expected = map mkCallHierarchyOutgoingCall items+    item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)+    res <- Test.outgoingCalls (mkOutgoingCallsParam item)+    liftIO $ sort expected @=? sort res+    closeDoc doc++outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion+outgoingCallMultiFileTestCase filepath queryX queryY mp =+  runSessionWithServer def plugin testDataDir $ do+    doc <- openDoc filepath "haskell"+    waitForIndex (testDataDir </> filepath)+    items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do+              p <- openDoc fp "haskell"+              waitForKickDone+              concatMapM (\((x, y), range) ->+                  Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y)+                    <&> map (, range)+                ) pr) mp+    let expected = map mkCallHierarchyOutgoingCall items+    item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)+    res <- Test.outgoingCalls (mkOutgoingCallsParam item)+    liftIO $ sort expected @=? sort res+    closeDoc doc++oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion+oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir ->+  runSessionWithServer def plugin dir $ do+    doc <- createDoc "A.hs" "haskell" contents+    waitForIndex (dir </> "A.hs")+    item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)+    liftIO $ expected (doc ^. L.uri) item+    closeDoc doc++expectOneElement :: [a] -> Session a+expectOneElement = \case+    [x] -> pure x+    xs  -> liftIO . assertFailure $ "Expecting exactly one element, but got " ++ show (length xs)++mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion+mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do+    assertHierarchyItem name name'+    assertHierarchyItem kind kind'+    assertHierarchyItem tags tags'+    assertHierarchyItem detail detail'+    assertHierarchyItem uri uri'+    assertHierarchyItem range range'+    assertHierarchyItem selRange selRange'+    case xdata' of+      Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata)+      Just v -> case Aeson.fromJSON v of+        Aeson.Success v' -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v')+        Aeson.Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err)+  where+    tags = Nothing+    detail = Just "Main"+    assertHierarchyItem :: forall a. (Eq a, Show a) => a -> a -> Assertion+    assertHierarchyItem = assertEqual ("In " ++ show c ++ ", got unexpected value for field")+    xdata = T.pack prefix <> ":" <> name <> ":Main:main"++mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV ::+  T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion+mkCallHierarchyItemC = mkCallHierarchyItem' "c"+mkCallHierarchyItemT = mkCallHierarchyItem' "t"+mkCallHierarchyItemV = mkCallHierarchyItem' "v"++mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall+mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item [range]++mkCallHierarchyOutgoingCall :: (CallHierarchyItem, Range) -> CallHierarchyOutgoingCall+mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item [range]++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-call-hierarchy-plugin" </> "test" </> "testdata"++mkPrepareCallHierarchyParam :: TextDocumentIdentifier -> Int -> Int -> CallHierarchyPrepareParams+mkPrepareCallHierarchyParam doc x y = CallHierarchyPrepareParams doc (Position (fromIntegral x) (fromIntegral y)) Nothing++mkIncomingCallsParam :: CallHierarchyItem -> CallHierarchyIncomingCallsParams+mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing++mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams+mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing++-- Wait for a special test message emitted by ghcide when a file is indexed,+-- so that call hierarchy can safely query the database.+waitForIndex :: FilePath -> Session ()+waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals+  where+    -- fp1 may be relative, in that case we check that it is a suffix of the+    -- filepath from the message+    lenientEquals :: FilePath -> Bool+    lenientEquals fp2+      | isRelative fp1 = any (equalFilePath fp1 . joinPath) $ tails $ splitDirectories fp2+      | otherwise = equalFilePath fp1 fp2+
+ plugins/hls-call-hierarchy-plugin/test/testdata/A.hs view
@@ -0,0 +1,11 @@+module A where+import B+import C++foo1 = B.a + C.a+foo2 = foo1 + B.a + C.b+foo3 = foo1 + foo2 + C.c++bar x = case x of+  A -> B.a + B.b + B.c + foo1+  B -> C.a + C.b + C.c + foo2
+ plugins/hls-call-hierarchy-plugin/test/testdata/B.hs view
@@ -0,0 +1,7 @@+module B where+import qualified C+data T = A | B++a = 3 + C.a+b = 4+c = 5
+ plugins/hls-call-hierarchy-plugin/test/testdata/C.hs view
@@ -0,0 +1,5 @@+module C where++a = 3+b = 4+c = 5
+ plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["A", "B", "C"]}}
+ plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE ViewPatterns #-}+-- | An HLS plugin to provide code actions to change type signatures+module Ide.Plugin.ChangeTypeSignature (descriptor+                                      -- * For Unit Tests+                                      , errorMessageRegexes+                                      ) where++import           Control.Monad                    (guard)+import           Control.Monad.IO.Class           (MonadIO)+import           Control.Monad.Trans.Except       (ExceptT)+import           Data.Foldable                    (asum)+import qualified Data.Map                         as Map+import           Data.Maybe                       (mapMaybe)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Development.IDE                  (realSrcSpanToRange)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.RuleTypes   (GetParsedModule (GetParsedModule))+import           Development.IDE.Core.Service     (IdeState)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Util         (printOutputable)+import           Generics.SYB                     (extQ, something)+import           Ide.Plugin.Error                 (PluginError,+                                                   getNormalizedFilePathE)+import           Ide.Types                        (PluginDescriptor (..),+                                                   PluginId (PluginId),+                                                   PluginMethodHandler,+                                                   defaultPluginDescriptor,+                                                   mkPluginHandler)+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Text.Regex.TDFA                  ((=~))++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")+  { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) }++codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = do+      nfp <- getNormalizedFilePathE uri+      decls <- getDecls plId ideState nfp+      let actions = mapMaybe (generateAction plId uri decls) diags+      pure $ InL actions++getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]+getDecls (PluginId changeTypeSignatureId) state =+    runActionE (T.unpack changeTypeSignatureId <> ".GetParsedModule") state+    . fmap (hsmodDecls . unLoc . pm_parsed_source)+    . useE GetParsedModule++-- | Text representing a Declaration's Name+type DeclName = Text+-- | The signature provided by GHC Error Message (Expected type)+type ExpectedSig = Text+-- | The signature provided by GHC Error Message (Actual type)+type ActualSig = Text++-- | DataType that encodes the necessary information for changing a type signature+data ChangeSignature = ChangeSignature {+                         -- | The expected type based on Signature+                         expectedType  :: ExpectedSig+                         -- | the Actual Type based on definition+                         , actualType  :: ActualSig+                         -- | the declaration name to be updated+                         , declName    :: DeclName+                         -- | the location of the declaration signature+                         , declSrcSpan :: RealSrcSpan+                         -- | the diagnostic to solve+                         , diagnostic  :: Diagnostic+                         }++-- | Create a CodeAction from a Diagnostic+generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)+generateAction plId uri decls diag = changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls diag++-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan+diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature+diagnosticToChangeSig decls diagnostic = do+    -- regex match on the GHC Error Message+    (expectedType, actualType, declName) <- matchingDiagnostic diagnostic+    -- Find the definition and it's location+    declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName)+    pure $ ChangeSignature{..}+++-- | If a diagnostic has the proper message create a ChangeSignature from it+matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName)+matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes+    where+        unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName)+        -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match+        unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name)+        unwrapMatch _                              = Nothing++-- | List of regexes that match various Error Messages+errorMessageRegexes :: [Text]+errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests+    "Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’"+    , "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’"+    -- GHC >9.2 version of the first error regex+    , "Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’"+    ]++-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches+-- both the name given and the Expected Type, and return the type signature location+findSigLocOfStringDecl :: [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan+findSigLocOfStringDecl decls expectedType declName = something (const Nothing `extQ` findSig `extQ` findLocalSig) decls+    where+        -- search for Top Level Signatures+        findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan+        findSig = \case+            L (locA -> (RealSrcSpan rss _)) (SigD _ sig) -> case sig of+              ts@(TypeSig _ idsSig _) -> isMatch ts idsSig >> pure rss+              _                       -> Nothing+            _ -> Nothing++        -- search for Local Signatures+        findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan+        findLocalSig = \case+          (L (locA -> (RealSrcSpan rss _)) ts@(TypeSig _ idsSig _)) -> isMatch ts idsSig >> pure rss+          _          -> Nothing++        -- Does the declName match? and does the expected signature match?+        isMatch ts idsSig = do+                ghcSig <- sigToText ts+                guard (any compareId idsSig && expectedType == ghcSig)++        -- Given an IdP check to see if it matches the declName+        compareId (L _ id') = declName == occNameString (occName id')+++-- | Pretty Print the Type Signature (to validate GHC Error Message)+sigToText :: Sig GhcPs -> Maybe Text+sigToText = \case+  ts@TypeSig {} -> Just $ stripSignature $ printOutputable ts+  _             -> Nothing++stripSignature :: Text -> Text+-- for whatever reason incoming signatures MAY have new lines after "::" or "=>"+stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig+                                                -- remove constraints+                                                then T.strip $ snd $ T.breakOnEnd " => " sig+                                                else T.strip $ snd $ T.breakOnEnd " :: " sig++changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction+changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} =+    InR CodeAction { _title       = mkChangeSigTitle declName actualType+                   , _kind        = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))+                   , _diagnostics = Just [diagnostic]+                   , _isPreferred = Nothing+                   , _disabled    = Nothing+                   , _edit        = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)+                   , _command     = Nothing+                   , _data_       = Nothing+                   }++mkChangeSigTitle :: Text -> Text -> Text+mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> "’ to: " <> actualType++mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit+mkChangeSigEdit uri ss replacement =+        let txtEdit = TextEdit (realSrcSpanToRange ss) replacement+            changes = Just $ Map.singleton uri [txtEdit]+        in WorkspaceEdit changes Nothing Nothing++mkNewSignature :: Text -> Text -> Text+mkNewSignature declName actualType = declName <> " :: " <> actualType
+ plugins/hls-change-type-signature-plugin/test/Main.hs view
@@ -0,0 +1,135 @@+module Main where++import           Control.Monad                  (void)+import           Data.Either                    (rights)+import           Data.Text                      (Text)+import qualified Data.Text                      as T+import qualified Data.Text.IO                   as TIO+import           Ide.Plugin.ChangeTypeSignature (errorMessageRegexes)+import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature+import           System.FilePath                ((<.>), (</>))+import           Test.Hls                       (CodeAction (..), Command,+                                                 GhcVersion (..),+                                                 PluginTestDescriptor,+                                                 Position (Position),+                                                 Range (Range), Session,+                                                 TestName, TestTree,+                                                 TextDocumentIdentifier,+                                                 assertFailure, def,+                                                 defaultTestRunner,+                                                 executeCodeAction,+                                                 getCodeActions,+                                                 goldenWithHaskellDoc,+                                                 knownBrokenForGhcVersions,+                                                 liftIO,+                                                 mkPluginTestDescriptor',+                                                 openDoc, runSessionWithServer,+                                                 testCase, testGroup, toEither,+                                                 type (|?),+                                                 waitForAllProgressDone,+                                                 waitForDiagnostics, (@?=))+import           Text.Regex.TDFA                ((=~))++main :: IO ()+main = defaultTestRunner test++changeTypeSignaturePlugin :: PluginTestDescriptor ()+changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature"++test :: TestTree+test = testGroup "changeTypeSignature" [+        testRegexes+        , codeActionTest "TExpectedActual" 4 11+        , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Error Message in 9.2/9.4 does not provide enough info" $ codeActionTest "TRigidType" 4 14+        , codeActionTest "TRigidType2" 4 6+        , codeActionTest "TLocalBinding" 7 22+        , codeActionTest "TLocalBindingShadow1" 11 8+        , codeActionTest "TLocalBindingShadow2" 7 22+        , codeActionProperties "TErrorGivenPartialSignature" [(4, 13)] $ \actions -> liftIO $ length actions @?= 0+    ]++testRegexes :: TestTree+testRegexes = testGroup "Regex Testing" [+        testRegexOne+        , testRegexTwo+        , testRegex921One+    ]++testRegexOne :: TestTree+testRegexOne = testGroup "Regex One" [+        regexTest "error1.txt" regex True+        , regexTest "error2.txt" regex True+        , regexTest "error3.txt" regex False+        , regexTest "error4.txt" regex True+        , regexTest "error5.txt" regex True+    ]+    where+        regex = errorMessageRegexes !! 0++testRegexTwo :: TestTree+testRegexTwo = testGroup "Regex Two" [+        regexTest "error1.txt" regex False+        , regexTest "error2.txt" regex False+        , regexTest "error3.txt" regex True+        , regexTest "error4.txt" regex False+        , regexTest "error5.txt" regex False+    ]+    where+        regex = errorMessageRegexes !! 1++-- test ghc-9.2 error message regex+testRegex921One :: TestTree+testRegex921One = testGroup "Regex One" [+        regexTest "ghc921-error1.txt" regex True+        , regexTest "ghc921-error2.txt" regex True+        , regexTest "ghc921-error3.txt" regex True+    ]+    where+        regex = errorMessageRegexes !! 2++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-change-type-signature-plugin" </> "test" </> "testdata"++goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs"++codeActionTest :: FilePath -> Int -> Int -> TestTree+codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do+    void waitForDiagnostics  -- code actions are triggered from Diagnostics+    void waitForAllProgressDone  -- apparently some tests need this to get the CodeAction to show up+    actions <- getCodeActions doc (pointRange line col)+    foundActions <- findChangeTypeActions actions+    liftIO $ length foundActions @?= 1+    executeCodeAction (head foundActions)++codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree+codeActionProperties fp locs assertions = testCase fp $ do+    runSessionWithServer def changeTypeSignaturePlugin testDataDir $ do+        openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions+    where+        codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs++findChangeTypeActions :: [Command |? CodeAction] -> Session [CodeAction]+findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither+    where+        isChangeTypeAction CodeAction{_kind} = case _kind of+          Nothing -> False+          Just kind -> case kind of+            "quickfix.changeTypeSignature" -> True+            _                              -> False+++regexTest :: FilePath -> Text -> Bool -> TestTree+regexTest fp regex shouldPass = testCase fp $ do+    msg <- TIO.readFile (testDataDir </> fp)+    case (msg =~ regex  :: (Text, Text, Text, [Text]), shouldPass) of+        ((_, _, _, [_, _, _, _]), True) -> pure ()+        ((_, _, _, [_, _, _, _]), False) -> assertFailure $  "Unexpected match: " <> fp <> " with " <> T.unpack regex+        (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex+        (_, False) -> pure ()++pointRange :: Int -> Int -> Range+pointRange+  (subtract 1 -> fromIntegral -> line)+  (subtract 1 -> fromIntegral -> col) =+    Range (Position line col) (Position line $ col + 1)
+ plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs view
@@ -0,0 +1,4 @@+module ErrorGivenPartialSignature where++partial :: Int -> Int+partial x = init x
+ plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs view
@@ -0,0 +1,6 @@+module TExpectedActual where++fullSig :: [Int] -> Int+fullSig = go+    where+        go = head . reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs view
@@ -0,0 +1,6 @@+module TExpectedActual where++fullSig :: Int -> Int+fullSig = go+    where+        go = head . reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs view
@@ -0,0 +1,8 @@+module TLocalBinding where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0)+              test = forM+          in x + 1
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs view
@@ -0,0 +1,8 @@+module TLocalBinding where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: Int -> Int+              test = forM+          in x + 1
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs view
@@ -0,0 +1,11 @@+module TLocalBindingShadow1 where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: Int -> Int+              test = (+2)+          in test x++test :: [Double] -> (Double -> m0 b0) -> m0 [b0]+test = forM
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs view
@@ -0,0 +1,11 @@+module TLocalBindingShadow1 where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: Int -> Int+              test = (+2)+          in test x++test :: [Double] -> Double+test = forM
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs view
@@ -0,0 +1,11 @@+module TLocalBindingShadow2 where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0)+              test = forM+          in test x++test :: String -> String+test = reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs view
@@ -0,0 +1,11 @@+module TLocalBindingShadow2 where++import Control.Monad (forM)++local :: Int -> Int+local x = let test :: Int -> Int+              test = forM+          in test x++test :: String -> String+test = reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs view
@@ -0,0 +1,6 @@+module TRigidType where++test :: [[Int]] -> Int+test = go . head . reverse+    where+        go = head . reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs view
@@ -0,0 +1,6 @@+module TRigidType where++test :: a -> Int+test = go . head . reverse+    where+        go = head . reverse
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.expected.hs view
@@ -0,0 +1,4 @@+module TRigidType2 where++test :: [Int] -> Int+test = head 
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs view
@@ -0,0 +1,4 @@+module TRigidType2 where++test :: a -> Int+test = head 
+ plugins/hls-change-type-signature-plugin/test/testdata/error1.txt view
@@ -0,0 +1,6 @@+    • Couldn't match type ‘Int’+                     with ‘Data.HashSet.Internal.HashSet Int’+      Expected type: Int -> Int+        Actual type: Data.HashSet.Internal.HashSet Int -> Int+    • In the expression: head . toList+      In an equation for ‘test’: test = head . toList
+ plugins/hls-change-type-signature-plugin/test/testdata/error2.txt view
@@ -0,0 +1,6 @@+    • Couldn't match type ‘b0 -> t0 a0 -> b0’ with ‘Int’+      Expected type: Int -> Int+        Actual type: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0+    • Probable cause: ‘foldl’ is applied to too few arguments+      In the expression: foldl+      In an equation for ‘test’: test = foldl
+ plugins/hls-change-type-signature-plugin/test/testdata/error3.txt view
@@ -0,0 +1,10 @@+    • Couldn't match expected type ‘Int’ with actual type ‘[Int]’+    • In the expression: map (+ x) [1, 2, 3]+      In an equation for ‘test’:+          test x+            = map (+ x) [1, 2, 3]+            where+                go = head . reverse+    |+152 | test x = map (+ x) [1,2,3]+    |          ^^^^^^^^^^^^^^^^^
+ plugins/hls-change-type-signature-plugin/test/testdata/error4.txt view
@@ -0,0 +1,19 @@+    • Couldn't match type ‘a’ with ‘[[Int]]’+      ‘a’ is a rigid type variable bound by+        the type signature for:+          test :: forall a. Ord a => a -> Int+        at src/Ide/Plugin/ChangeTypeSignature.hs:154:1-25+      Expected type: a -> Int+        Actual type: [[Int]] -> Int+    • In the expression: go . head . reverse+      In an equation for ‘test’:+          test+            = go . head . reverse+            where+                go = head . reverse+    • Relevant bindings include+        test :: a -> Int+          (bound at src/Ide/Plugin/ChangeTypeSignature.hs:155:1)+    |+155 | test = go . head . reverse+    |        ^^^^^^^^^^^^^^^^^^^
+ plugins/hls-change-type-signature-plugin/test/testdata/error5.txt view
@@ -0,0 +1,15 @@+    • Couldn't match type ‘(a0 -> m0 b0) -> m0 (t0 b0)’ with ‘Int’+      Expected type: Int -> Int+        Actual type: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0)+    • Probable cause: ‘forM’ is applied to too few arguments+      In the expression: forM+      In an equation for ‘test’: test = forM+      In an equation for ‘implicit’:+          implicit+            = return OpTEmpty+            where+                test :: Int -> Int+                test = forM+   |+82 |     test = forM+   |            ^^^^
+ plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt view
@@ -0,0 +1,9 @@+    • Couldn't match type ‘Data.Set.Internal.Set Int’ with ‘Int’+      Expected: Int -> [Int]+        Actual: Data.Set.Internal.Set Int -> [Int]+    • In the second argument of ‘(.)’, namely ‘toList’+      In the expression: head . toList+      In an equation for ‘test’: test = head . toList+   |+83 | test = head . toList+   |               ^^^^^^
+ plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt view
@@ -0,0 +1,9 @@+    • Couldn't match type ‘b0 -> a0 -> b0’ with ‘Int’+      Expected: Int -> Int+        Actual: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0+    • Probable cause: ‘foldl’ is applied to too few arguments+      In the expression: foldl+      In an equation for ‘test’: test = foldl+   |+83 | test = foldl+   |
+ plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt view
@@ -0,0 +1,9 @@+    • Couldn't match type ‘[Int]’ with ‘Int’+      Expected: Int -> [Int]+        Actual: [Int] -> [Int]+    • In the second argument of ‘(.)’, namely ‘reverse’+      In the expression: head . reverse+      In an equation for ‘test’: test = head . reverse+   |+84 |               test = head . reverse+   |
+ plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,12 @@+cradle:+  direct:+    arguments:+      - -i+      - -i.+      - TExpectedActual+      - TRigidType+      - TErrorGivenPartialSignature+      - TLocalBinding+      - TLocalBindingShadow1+      - TLocalBindingShadow2+      - -Wall
+ plugins/hls-class-plugin/src/Ide/Plugin/Class.hs view
@@ -0,0 +1,25 @@+module Ide.Plugin.Class (descriptor, Log(..)) where++import           Development.IDE               (IdeState, Recorder,+                                                WithPriority)+import           Ide.Plugin.Class.CodeAction+import           Ide.Plugin.Class.CodeLens+import           Ide.Plugin.Class.Types+import           Ide.Types+import           Language.LSP.Protocol.Message+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId "Provides code actions and lenses for working with typeclasses")+    { pluginCommands = commands plId+    , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder+    , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder)+        <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens+        <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve+    }++commands :: PluginId -> [PluginCommand IdeState]+commands plId+  = [ PluginCommand codeActionCommandId+        "add placeholders for minimal methods" (addMethodPlaceholders plId)+    , PluginCommand typeLensCommandId+        "add type signatures for instance methods" (codeLensCommandHandler plId)+    ]
+ plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns    #-}++module Ide.Plugin.Class.CodeAction where++import           Control.Lens                         hiding (List, use)+import           Control.Monad.Error.Class            (MonadError (throwError))+import           Control.Monad.Extra+import           Control.Monad.IO.Class               (liftIO)+import           Control.Monad.Trans.Class            (lift)+import           Control.Monad.Trans.Except           (ExceptT)+import           Control.Monad.Trans.Maybe+import           Data.Aeson                           hiding (Null)+import           Data.Bifunctor                       (second)+import           Data.Either.Extra                    (rights)+import           Data.List+import           Data.List.Extra                      (nubOrdOn)+import qualified Data.Map.Strict                      as Map+import           Data.Maybe                           (isNothing, listToMaybe,+                                                       mapMaybe)+import qualified Data.Set                             as Set+import qualified Data.Text                            as T+import           Development.IDE+import           Development.IDE.Core.Compile         (sourceTypecheck)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (fromCurrentRange)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           Development.IDE.Spans.AtPoint        (pointCommand)+import           Ide.Plugin.Class.ExactPrint+import           Ide.Plugin.Class.Types+import           Ide.Plugin.Class.Utils+import qualified Ide.Plugin.Config+import           Ide.Plugin.Error+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server++addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams+addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do+    caps <- lift getClientCapabilities+    nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)+    pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state+        $ useE GetParsedModule nfp+    (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state+        $ useE GhcSessionDeps nfp+    (old, new) <- handleMaybeM (PluginInternalError "Unable to makeEditText")+        $ liftIO $ runMaybeT+        $ makeEditText pm df param+    pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs+    let edit =+            if withSig+            then mergeEdit (workspaceEdit caps old new) pragmaInsertion+            else workspaceEdit caps old new++    void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())++    pure $ InR Null+    where+        toTextDocumentEdit edit =+            TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit]++        mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit+        mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit+            { _documentChanges =+                (\x -> x ++ map (InL . toTextDocumentEdit) edits)+                    <$> _documentChanges+            , ..+            }++        workspaceEdit caps old new+            = diffText caps (verTxtDocId, old) new IncludeDeletions++-- |+-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is+-- sensitive to the format of diagnostic messages from GHC.+codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do+    verTxtDocId <- lift $ getVersionedTextDoc docId+    nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)+    actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags+    pure $ InL actions+    where+        diags = context ^. L.diagnostics++        ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags+        methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags++        mkActions+            :: NormalizedFilePath+            -> VersionedTextDocumentIdentifier+            -> Diagnostic+            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction]+        mkActions docPath verTxtDocId diag = do+            (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state+                $ useWithStaleE GetHieAst docPath+            instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $+                              fromCurrentRange pmap range ^? _Just . L.start+                              & fmap (L.character -~ 1)+            ident <- findClassIdentifier ast instancePosition+            cls <- findClassFromIdentifier docPath ident+            InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state+                $ useE GetInstanceBindTypeSigs docPath+            (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath+            (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath+            implemented <- findImplementedMethods ast instancePosition+            logWith recorder Info (LogImplementedMethods cls implemented)+            pure+                $ concatMap mkAction+                $ nubOrdOn snd+                $ filter ((/=) mempty . snd)+                $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))+                $ mkMethodGroups hsc gblEnv range sigs cls+            where+                range = diag ^. L.range++                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]+                mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]+                    where+                        minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls+                        allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)++                mkAction :: MethodGroup -> [Command |? CodeAction]+                mkAction (name, methods)+                    = [ mkCodeAction title+                            $ mkLspCommand plId codeActionCommandId title+                                (Just $ mkCmdParams methods False)+                      , mkCodeAction titleWithSig+                            $ mkLspCommand plId codeActionCommandId titleWithSig+                                (Just $ mkCmdParams methods True)+                      ]+                    where+                        title = "Add placeholders for " <> name+                        titleWithSig = title <> " with signature(s)"++                mkCmdParams :: [(T.Text, T.Text)] -> Bool -> [Value]+                mkCmdParams methodGroup withSig =+                    [toJSON (AddMinimalMethodsParams verTxtDocId range methodGroup withSig)]++                mkCodeAction title cmd+                    = InR+                    $ CodeAction+                        title+                        (Just CodeActionKind_QuickFix)+                        (Just [])+                        Nothing+                        Nothing+                        Nothing+                        (Just cmd)+                        Nothing++        findClassIdentifier hf instancePosition =+            handleMaybe (PluginInternalError "No Identifier found")+                $ listToMaybe+                $ mapMaybe listToMaybe+                $ pointCommand hf instancePosition+                    ( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds)+                        <=< nodeChildren+                    )++        findImplementedMethods+            :: HieASTs a+            -> Position+            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text]+        findImplementedMethods asts instancePosition = do+            pure+                $ concat+                $ pointCommand asts instancePosition+                $ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers++        -- | Recurses through the given AST to find identifiers which are+        -- 'InstanceValBind's.+        findInstanceValBindIdentifiers :: HieAST a -> [Identifier]+        findInstanceValBindIdentifiers ast =+            let valBindIds = Map.keys+                            . Map.filter (any isInstanceValBind . identInfo)+                            $ getNodeIds ast+            in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast)++        findClassFromIdentifier docPath (Right name) = do+            (hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state+                $ useWithStaleE GhcSessionDeps docPath+            (tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state+                $ useWithStaleE TypeCheck docPath+            handleMaybeM (PluginInternalError "initTcWithGbl failed")+                . liftIO+                . fmap snd+                . initTcWithGbl hscenv thisMod ghostSpan $ do+                    tcthing <- tcLookup name+                    case tcthing of+                        AGlobal (AConLike (RealDataCon con))+                            | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls+                        _ -> fail "Ide.Plugin.Class.findClassFromIdentifier"+        findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier")++-- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc+isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool+isClassNodeIdentifier (Right i) ident  | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident+isClassNodeIdentifier _ _ = False++isClassMethodWarning :: T.Text -> Bool+isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"++isInstanceValBind :: ContextInfo -> Bool+isInstanceValBind (ValBind InstanceBind _ _) = True+isInstanceValBind _                          = False++type MethodSignature = T.Text+type MethodName = T.Text+type MethodDefinition = (MethodName, MethodSignature)+type MethodGroup = (T.Text, [MethodDefinition])++makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition+makeMethodDefinition hsc gblEnv sig = (name, signature)+    where+        name = T.drop (T.length bindingPrefix) (printOutputable  (bindName sig))+        signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig))++makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]+makeMethodDefinitions hsc gblEnv range sigs =+    [ makeMethodDefinition hsc gblEnv sig+    | sig <- sigs+    , inRange range (getSrcSpan $ bindName sig)+    ]++signatureToName :: InstanceBindTypeSig -> T.Text+signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))++-- Return [groupName text, [(methodName text, signature text)]]+minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]+minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef+    where+        makeMethodGroup methodDefinitions =+            let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions+            in  (name, methodDefinitions)++        go (Var mn)   = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs+        go (Or ms)    = concatMap (go . unLoc) ms+        go (And ms)   = foldr (liftA2 (<>) . go . unLoc) [[]] ms+        go (Parens m) = go (unLoc m)+
+ plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ViewPatterns    #-}+module Ide.Plugin.Class.CodeLens where++import           Control.Lens                         ((&), (?~), (^.))+import           Control.Monad.Trans.Class            (MonadTrans (lift))+import           Data.Aeson                           hiding (Null)+import qualified Data.IntMap.Strict                   as IntMap+import           Data.Maybe                           (mapMaybe, maybeToList)+import qualified Data.Text                            as T+import           Development.IDE+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping+import           Development.IDE.GHC.Compat+import           Development.IDE.Spans.Pragmas        (getFirstPragma,+                                                       insertNewPragma)+import           Ide.Plugin.Class.Types+import           Ide.Plugin.Class.Utils+import           Ide.Plugin.Error+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server                  (sendRequest)++-- The code lens method is only responsible for providing the ranges of the code+-- lenses matched to a unique id+codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens+codeLens state _plId clp = do+    nfp <-  getNormalizedFilePathE $ clp ^. L.textDocument . L.uri+    (InstanceBindLensResult (InstanceBindLens{lensRange}), pm)+        <- runActionE "classplugin.GetInstanceBindLens" state+            -- Using stale results means that we can almost always return a+            -- value. In practice this means the lenses don't 'flicker'+            $ useWithStaleE GetInstanceBindLens nfp+    pure $ InL $ mapMaybe (toCodeLens pm) lensRange+    where toCodeLens pm (range, int) =+            let newRange = toCurrentRange pm range+            in (\r -> CodeLens r Nothing (Just $ toJSON int)) <$> newRange++-- The code lens resolve method matches a title to each unique id+codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve+codeLensResolve state plId cl uri uniqueID = do+    nfp <-  getNormalizedFilePathE uri+    (InstanceBindLensResult (InstanceBindLens{lensDetails}), pm)+        <- runActionE "classplugin.GetInstanceBindLens" state+            $ useWithStaleE GetInstanceBindLens nfp+    (tmrTypechecked -> gblEnv, _) <- runActionE "classplugin.codeAction.TypeCheck" state $ useWithStaleE TypeCheck nfp+    (hscEnv -> hsc, _) <- runActionE "classplugin.codeAction.GhcSession" state $ useWithStaleE GhcSession nfp+    (range, name, typ) <- handleMaybe PluginStaleResolve+                    $ IntMap.lookup uniqueID lensDetails+    let title = prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ)+    edit <- handleMaybe (PluginInvalidUserState "toCurrentRange") $ makeEdit range title pm+    let command = mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri edit])+    pure $ cl & L.command ?~ command+    where+        makeEdit :: Range -> T.Text -> PositionMapping -> Maybe TextEdit+        makeEdit range bind mp =+            let startPos = range ^. L.start+                insertChar = startPos ^. L.character+                insertRange = Range startPos startPos+            in case toCurrentRange mp insertRange of+                Just rg -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")+                Nothing -> Nothing++-- Finally the command actually generates and applies the workspace edit for the+-- specified unique id.+codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand+codeLensCommandHandler plId state _ InstanceBindLensCommand{commandUri, commandEdit} = do+    nfp <-  getNormalizedFilePathE commandUri+    (InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _)+        <- runActionE "classplugin.GetInstanceBindLens" state+            $ useWithStaleE GetInstanceBindLens nfp+    -- We are only interested in the pragma information if the user does not+    -- have the InstanceSigs extension enabled+    mbPragma <- if InstanceSigs `elem` lensEnabledExtensions+                then pure Nothing+                else Just <$> getFirstPragma plId state nfp+    let -- By mapping over our Maybe NextPragmaInfo value, we only compute this+        -- edit if we actually need to.+        pragmaInsertion =+            maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma+        wEdit = workspaceEdit pragmaInsertion+    _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ())+    pure $ InR Null+    where+        workspaceEdit pragmaInsertion=+            WorkspaceEdit+                (pure [(commandUri, commandEdit : pragmaInsertion)])+                Nothing+                Nothing++++
+ plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Class.ExactPrint where++import           Control.Monad.Trans.Maybe+import qualified Data.Text                               as T+import           Development.IDE.GHC.Compat+import           Ide.Plugin.Class.Types+import           Ide.Plugin.Class.Utils+import           Language.Haskell.GHC.ExactPrint+import           Language.Haskell.GHC.ExactPrint.Parsers++import           Data.Either.Extra                       (eitherToMaybe)+import           Data.Functor.Identity                   (Identity)+import           GHC.Parser.Annotation+import           Language.LSP.Protocol.Types             (Range)++makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text)+makeEditText pm df AddMinimalMethodsParams{..} = do+    mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup+    let ps = makeDeltaAst $ pm_parsed_source pm+        old = T.pack $ exactPrint ps+        (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig)+        new = T.pack $ exactPrint ps'+    pure (old, new)++makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (LHsDecl GhcPs, LHsDecl GhcPs)+makeMethodDecl df (mName, sig) = do+    name <- eitherToMaybe $ parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _"+    sig' <- eitherToMaybe $ parseDecl df (T.unpack sig) $ T.unpack sig+    pure (name, sig')++#if MIN_VERSION_ghc(9,5,0)+addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located (HsModule GhcPs))+#else+addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule)+#endif+addMethodDecls ps mDecls range withSig+    | withSig = go (concatMap (\(decl, sig) -> [sig, decl]) mDecls)+    | otherwise = go (map fst mDecls)+    where+    go inserting = do+        allDecls <- hsDecls ps+        case break (inRange range . getLoc) allDecls of+            (before, L l inst : after) -> replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ after))+            (before, []) -> replaceDecls ps before++    -- Add `where` keyword for `instance X where` if `where` is missing.+    --+    -- The `where` in ghc-9.2 is now stored in the instance declaration+    --   directly. More precisely, giving an `HsDecl GhcPs`, we have:+    --   InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey),+    --   here `AnnEpAnn` keeps the track of Anns.+    --+    -- See the link for the original definition:+    --   https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl+    addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) =+        case cid_ext of+            (EpAnn entry anns comments, key) ->+                    InstD xInstD (ClsInstD ext decl {+                    cid_ext = (EpAnn+                                entry+                                (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns)+                                comments+                                , key)+                    })+            _ -> instd+    addWhere decl = decl++    newLine (L l e) =+        let dp = deltaPos 1 defaultIndent+        in L (noAnnSrcSpanDP (getLoc l) dp <> l) e+
+ plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveAnyClass  #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE ViewPatterns    #-}++module Ide.Plugin.Class.Types where++import           Control.DeepSeq                  (rwhnf)+import           Control.Monad.Extra              (mapMaybeM, whenMaybe)+import           Control.Monad.IO.Class           (liftIO)+import           Control.Monad.Trans.Maybe        (MaybeT (MaybeT, runMaybeT))+import           Data.Aeson+import qualified Data.IntMap                      as IntMap+import           Data.List.Extra                  (firstJust)+import           Data.Maybe                       (catMaybes, mapMaybe,+                                                   maybeToList)+import qualified Data.Text                        as T+import           Data.Unique                      (hashUnique, newUnique)+import           Development.IDE+import           Development.IDE.Core.PluginUtils (useMT)+import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.GHC.Compat       hiding (newUnique, (<+>))+import           Development.IDE.GHC.Compat.Util  (bagToList)+import           Development.IDE.Graph.Classes+import           GHC.Generics+import           Ide.Plugin.Class.Utils+import           Ide.Types+import           Language.LSP.Protocol.Types      (TextEdit,+                                                   VersionedTextDocumentIdentifier)++typeLensCommandId :: CommandId+typeLensCommandId = "classplugin.typelens"++codeActionCommandId :: CommandId+codeActionCommandId = "classplugin.codeaction"++-- | Default indent size for inserting+defaultIndent :: Int+defaultIndent = 2++data AddMinimalMethodsParams = AddMinimalMethodsParams+    { verTxtDocId :: VersionedTextDocumentIdentifier+    , range       :: Range+    , methodGroup :: [(T.Text, T.Text)]+    -- ^ (name text, signature text)+    , withSig     :: Bool+    }+    deriving (Show, Eq, Generic, ToJSON, FromJSON)++-- |The InstanceBindTypeSigs Rule collects the instance bindings type+-- signatures (both name and type). It is used by both the code actions and the+-- code lenses+data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs+    deriving (Generic, Show, Eq, Ord, Hashable, NFData)++data InstanceBindTypeSig = InstanceBindTypeSig+    { bindName :: Name+    , bindType :: Type+    }++newtype InstanceBindTypeSigsResult =+    InstanceBindTypeSigsResult [InstanceBindTypeSig]++instance Show InstanceBindTypeSigsResult where+    show _ = "<InstanceBindTypeSigs>"++instance NFData InstanceBindTypeSigsResult where+    rnf = rwhnf++type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult++-- |The necessary data to execute our code lens+data InstanceBindLensCommand = InstanceBindLensCommand+    { -- |The URI needed to run actions in the command+      commandUri  :: Uri+      -- |The specific TextEdit we want to apply. This does not include the+      -- pragma edit which is computed in the command+    , commandEdit :: TextEdit }+    deriving (Generic, FromJSON, ToJSON)++-- | The InstanceBindLens rule is specifically for code lenses. It  relies on+-- the InstanceBindTypeSigs rule, filters out irrelevant matches and signatures+-- that can't be matched to a source span. It provides all the signatures linked+-- to a unique ID to aid in resolving. It also provides a list of enabled+-- extensions.+data GetInstanceBindLens = GetInstanceBindLens+    deriving (Generic, Show, Eq, Ord, Hashable, NFData)++data InstanceBindLens = InstanceBindLens+    { -- |What we need to provide the code lens. The range linked with+      -- a unique ID that will allow us to resolve the rest of the data later+      lensRange             :: [(Range, Int)]+      -- |Provides the necessary data to allow us to display the+      -- title of the lens and compute a TextEdit for it.+    , lensDetails           :: IntMap.IntMap (Range, Name, Type)+    -- |Provides currently enabled extensions, allowing us to conditionally+    -- insert needed extensions.+    , lensEnabledExtensions :: [Extension]+    }++newtype InstanceBindLensResult =+    InstanceBindLensResult InstanceBindLens++instance Show InstanceBindLensResult where+    show _ = "<InstanceBindLens>"++instance NFData InstanceBindLensResult where+    rnf = rwhnf++type instance RuleResult GetInstanceBindLens = InstanceBindLensResult++data Log+  = LogImplementedMethods Class [T.Text]+  | LogShake Shake.Log++instance Pretty Log where+  pretty = \case+    LogImplementedMethods cls methods ->+      pretty ("Detected implemented methods for class" :: String)+        <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name+        <+> pretty methods+    LogShake log -> pretty log++data BindInfo = BindInfo+    { bindSpan     :: SrcSpan+      -- ^ SrcSpan of the whole binding+    , bindNameSpan :: SrcSpan+      -- ^ SrcSpan of the binding name+    }++getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules ()+getInstanceBindLensRule recorder = do+    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do+        tmr@(tmrRenamed ->  (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp+        (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp++        let -- declared instance methods without signatures+            bindInfos = [ bind+                        | instds <- map group_instds tycls -- class instance decls+                        , instd <- instds+                        , inst <- maybeToList $ getClsInstD (unLoc instd)+                        , bind <- getBindSpanWithoutSig inst+                        ]+            targetSigs = matchBind bindInfos allBinds+        rangeIntNameType <- liftIO $ mapMaybeM getRangeWithSig targetSigs+        let lensRange = (\(range, int, _, _) -> (range, int)) <$> rangeIntNameType+            lensDetails = IntMap.fromList $ (\(range, int, name, typ) -> (int, (range, name, typ))) <$> rangeIntNameType+            lensEnabledExtensions = getExtensions $ tmrParsed tmr+        pure $ InstanceBindLensResult $ InstanceBindLens{..}+    where+        -- Match Binds with their signatures+        -- We try to give every `InstanceBindTypeSig` a `SrcSpan`,+        -- hence we can display signatures for `InstanceBindTypeSig` with span later.+        matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)]+        matchBind existedBinds allBindWithSigs =+            [firstJust (go bindSig) existedBinds | bindSig <- allBindWithSigs]+            where+                go :: InstanceBindTypeSig -> BindInfo -> Maybe (InstanceBindTypeSig,  SrcSpan)+                go bindSig bind = do+                    range <- (srcSpanToRange . bindNameSpan) bind+                    if inRange range (getSrcSpan $ bindName bindSig)+                    then Just (bindSig, bindSpan bind)+                    else Nothing++        getClsInstD (ClsInstD _ d) = Just d+        getClsInstD _              = Nothing++        getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames+        getSigName _                           = Nothing++        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]+        getBindSpanWithoutSig ClsInstDecl{..} =+            let bindNames = mapMaybe go (bagToList cid_binds)+                go (L l bind) = case bind of+                    FunBind{..}+                        -- `Generated` tagged for Template Haskell,+                        -- here we filter out nonsense generated bindings+                        -- that are nonsense for displaying code lenses.+                        --+                        -- See https://github.com/haskell/haskell-language-server/issues/3319+                        | not $ isGenerated (groupOrigin fun_matches)+                            -> Just $ L l fun_id+                    _       -> Nothing+                -- Existed signatures' name+                sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs+                toBindInfo (L l (L l' _)) = BindInfo+                    (locA l) -- bindSpan+                    (locA l') -- bindNameSpan+            in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames++        -- Get bind definition range with its rendered signature text+        getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan) -> IO (Maybe (Range, Int, Name, Type))+        getRangeWithSig (Just (bind, span)) = runMaybeT $ do+            range <- MaybeT . pure $ srcSpanToRange span+            uniqueID <- liftIO $ hashUnique <$> newUnique+            pure (range, uniqueID, bindName bind, bindType bind)+        getRangeWithSig Nothing = pure Nothing+++getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules ()+getInstanceBindTypeSigsRule recorder = do+    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> runMaybeT $ do+        (tmrTypechecked -> gblEnv ) <- useMT TypeCheck nfp+        (hscEnv -> hsc) <- useMT GhcSession nfp+        let binds = collectHsBindsBinders $ tcg_binds gblEnv+        (_, maybe [] catMaybes -> instanceBinds) <- liftIO $+            initTcWithGbl hsc gblEnv ghostSpan+#if MIN_VERSION_ghc(9,7,0)+              $ liftZonkM+#endif+              $ traverse bindToSig binds+        pure $ InstanceBindTypeSigsResult instanceBinds+    where+        bindToSig id = do+            let name = idName id+            whenMaybe (isBindingName name) $ do+                env <- tcInitTidyEnv+                let (_, ty) = tidyOpenType env (idType id)+                pure $ InstanceBindTypeSig name ty
+ plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Class.Utils where++import           Control.Monad.IO.Class           (MonadIO, liftIO)+import           Control.Monad.Trans.Except+import           Data.Char                        (isAlpha)+import           Data.List                        (isPrefixOf)+import           Data.String                      (IsString)+import qualified Data.Text                        as T+import           Development.IDE+import           Development.IDE.Core.PluginUtils+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           Development.IDE.Spans.Pragmas    (getNextPragmaInfo,+                                                   insertNewPragma)+import           Ide.Plugin.Error+import           Ide.PluginUtils+import           Language.LSP.Protocol.Types++-- | All instance bindings are started with `$c`+bindingPrefix :: IsString s => s+bindingPrefix = "$c"++isBindingName :: Name -> Bool+isBindingName name = isPrefixOf bindingPrefix $ occNameString $ nameOccName name++-- | Check if some `HasSrcSpan` value in the given range+inRange :: Range -> SrcSpan -> Bool+inRange range s = maybe False (subRange range) (srcSpanToRange s)++ghostSpan :: RealSrcSpan+ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1++-- | "$cname" ==> "name"+prettyBindingNameString :: T.Text -> T.Text+prettyBindingNameString name+    | T.isPrefixOf bindingPrefix name =+        toMethodName $ T.drop (T.length bindingPrefix) name+    | otherwise = name++showDoc :: HscEnv -> TcGblEnv -> Type -> String+showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty)+    where rdrEnv gblEnv = tcg_rdr_env gblEnv++-- | Paren the name for pretty display if necessary+toMethodName :: T.Text -> T.Text+toMethodName n+    | Just (h, _) <- T.uncons n+    , not (isAlpha h || h == '_')+    = "(" <> n <> ")"+    | otherwise+    = n++-- | Here we use `useWithStale` to compute, Using stale results means that we can almost always return a value.+--   In practice this means the lenses don't 'flicker'.+--   This function is also used in code actions, but it doesn't matter because our actions only work+--   if the module parsed success.+insertPragmaIfNotPresent :: (MonadIO m)+    => IdeState+    -> NormalizedFilePath+    -> Extension+    -> ExceptT PluginError m [TextEdit]+insertPragmaIfNotPresent state nfp pragma = do+    (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state+        $ useWithStaleE GhcSession nfp+    (_, fileContents) <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state+        $ getFileContents nfp+    (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state+        $ useWithStaleE GetParsedModuleWithComments nfp+    let exts = getExtensions pm+        info = getNextPragmaInfo sessionDynFlags fileContents+    pure [insertNewPragma info pragma | pragma `notElem` exts]
+ plugins/hls-class-plugin/test/Main.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import           Control.Exception             (catch)+import           Control.Lens                  (Prism', prism', view, (^.),+                                                (^..), (^?))+import           Control.Monad                 (void)+import           Data.Foldable                 (find)+import           Data.Maybe+import           Data.Row                      ((.==))+import qualified Data.Text                     as T+import qualified Ide.Plugin.Class              as Class+import qualified Language.LSP.Protocol.Lens    as L+import           Language.LSP.Protocol.Message+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++classPlugin :: PluginTestDescriptor Class.Log+classPlugin = mkPluginTestDescriptor Class.descriptor "class"++tests :: TestTree+tests = testGroup+  "class"+  [ codeActionTests+  , codeLensTests+  ]++codeActionTests :: TestTree+codeActionTests = testGroup+  "code actions"+  [ expectCodeActionsAvailable "Produces addMinimalMethodPlaceholders code actions for one instance" "T1"+      [ "Add placeholders for '=='"+      , "Add placeholders for '==' with signature(s)"+      , "Add placeholders for '/='"+      , "Add placeholders for '/=' with signature(s)"+      , "Add placeholders for all missing methods"+      , "Add placeholders for all missing methods with signature(s)"+      ]+  , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $+      getActionByTitle "Add placeholders for '=='"+  , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $+      getActionByTitle "Add placeholders for '/='"+  , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $+      getActionByTitle "Add placeholders for all missing methods"+  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $+      getActionByTitle "Add placeholders for 'fmap'"+  , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $+      getActionByTitle "Add placeholders for 'f','g'"+  , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $+      getActionByTitle "Add placeholders for 'g','h'"+  , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $+      getActionByTitle "Add placeholders for '_f'"+  , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $+      getActionByTitle "Add placeholders for '=='"+  , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $+      getActionByTitle "Add placeholders for 'g'"+  , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $+      getActionByTitle "Add placeholders for 'g','h'"+  , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $+      goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $+        getActionByTitle "Add placeholders for '==' with signature(s)"+  , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $+      getActionByTitle "Add placeholders for '==' with signature(s)"+  , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $+      getActionByTitle "Add placeholders for '==' with signature(s)"+  , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $+      getActionByTitle "Add placeholders for 'pure','<*>' with signature(s)"+  , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" []+  , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired"+      [ "Add placeholders for 'f','g'"+      , "Add placeholders for 'f','g' with signature(s)"+      ]+  , testCase "Update text document version" $ runSessionWithServer def classPlugin testDataDir $ do+    doc <- createDoc "Version.hs" "haskell" "module Version where"+    ver1 <- (^. L.version) <$> getVersionedDoc doc+    liftIO $ ver1 @?= 0++    -- Change the doc to ensure the version is not 0+    changeDoc doc+        [ TextDocumentContentChangeEvent . InR . (.==) #text $+            T.unlines ["module Version where", "data A a = A a", "instance Functor A where"]+        ]+    ver2 <- (^. L.version) <$> getVersionedDoc doc+    _ <- waitForDiagnostics+    liftIO $ ver2 @?= 1++    -- Execute the action and see what the version is+    action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc+    executeCodeAction action+    _ <- waitForDiagnostics+    ver3 <- (^. L.version) <$> getVersionedDoc doc+    liftIO $ ver3 @?= 2+    pure mempty+  ]++codeLensTests :: TestTree+codeLensTests = testGroup+    "code lens"+    [ testCase "Has code lens" $ do+        runSessionWithServer def classPlugin testDataDir $ do+            doc <- openDoc "CodeLensSimple.hs" "haskell"+            lens <- getAndResolveCodeLenses doc+            let titles = map (^. L.title) $ mapMaybe (^. L.command) lens+            liftIO $ titles @?=+                [ "(==) :: B -> B -> Bool"+                , "(==) :: A -> A -> Bool"+                ]+    , testCase "No lens for TH" $ do+        runSessionWithServer def classPlugin testDataDir $ do+            doc <- openDoc "TH.hs" "haskell"+            lens <- getAndResolveCodeLenses doc+            liftIO $ length lens @?= 0+    , testCase "Do not construct error action!, Ticket3942one" $ do+        runSessionWithServer def classPlugin testDataDir $ do+            doc <- openDoc "Ticket3942one.hs" "haskell"+            _ <- waitForDiagnosticsFrom doc+            lens <- getAllCodeActions doc+            -- should switch to `liftIO $ length lens @?= 2, when Ticket3942 is entirely fixed`+            -- current fix is just to make sure the code does not throw an exception that would mess up+            -- the client UI.+            liftIO $ length lens > 0 @?= True+        `catch` \(e :: SessionException) -> do+          liftIO $ assertFailure $ "classPluginTestError: "++ show e+    , goldenCodeLens "Apply code lens" "CodeLensSimple" 1+    , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0+    , goldenCodeLens "Apply code lens on the same line" "Inline" 0+    , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0+    , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $+        goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0+    , goldenCodeLens "Qualified name" "Qualified" 0+    , goldenCodeLens "Type family" "TypeFamily" 0+    , testCase "keep stale lens" $ do+        runSessionWithServer def classPlugin testDataDir $ do+            doc <- openDoc "Stale.hs" "haskell"+            oldLens <- getAndResolveCodeLenses doc+            let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_`+            _ <- applyEdit doc edit+            newLens <- getAndResolveCodeLenses doc+            liftIO $ (view L.command <$> newLens ) @?= (view L.command <$> oldLens)+    ]++_CACodeAction :: Prism' (Command |? CodeAction) CodeAction+_CACodeAction = prism' InR $ \case+  InR action -> Just action+  _          -> Nothing++goldenCodeLens :: TestName -> FilePath -> Int -> TestTree+goldenCodeLens title path idx =+    goldenWithHaskellDoc def classPlugin title testDataDir path "expected" "hs" $ \doc -> do+        lens <- getAndResolveCodeLenses doc+        executeCommand $ fromJust $ (lens !! idx) ^. L.command+        void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)++goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree+goldenWithClass title path desc findAction =+  goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do+    _ <- waitForDiagnosticsFrom doc+    actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc+    action <- findAction actions+    executeCodeAction action+    void $ skipManyTill anyMessage (getDocumentEdit doc)++getActionByTitle :: T.Text -> [CodeAction] -> Session CodeAction+getActionByTitle title actions = case find (\a -> a ^. L.title == title) actions of+    Just a -> pure a+    Nothing -> liftIO $ assertFailure $ "Action " <> show title <> " not found in " <> show [a ^. L.title | a <- actions]++expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree+expectCodeActionsAvailable title path actionTitles =+  testCase title $ do+    runSessionWithServer def classPlugin testDataDir $ do+      doc <- openDoc (path <.> "hs") "haskell"+      _ <- waitForDiagnosticsFrom doc+      caResults <- getAllCodeActions doc+      liftIO $ map (^? _CACodeAction . L.title) caResults+        @?= expectedActions+    where+      expectedActions = Just <$> actionTitles++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-class-plugin" </> "test" </> "testdata"
+ plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs view
@@ -0,0 +1,9 @@+module AllMethodsRequired where++class Test a where+  f :: a+  g :: a+  {-# MINIMAL f,g #-}++instance Test [a] where+
+ plugins/hls-class-plugin/test/testdata/CodeLensSimple.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensSimple where++data A+instance Eq A where+    (==) :: A -> A -> Bool+    (==) = _++data B+instance Eq B where+    (==)= _
+ plugins/hls-class-plugin/test/testdata/CodeLensSimple.hs view
@@ -0,0 +1,9 @@+module CodeLensSimple where++data A+instance Eq A where+    (==) = _++data B+instance Eq B where+    (==)= _
+ plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021 #-}+module CodeLensWithGHC2021 where++data A+instance Eq A where+    (==) :: A -> A -> Bool+    (==) = _
+ plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE GHC2021 #-}+module CodeLensWithGHC2021 where++data A+instance Eq A where+    (==) = _
+ plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensWithPragma where++data A+instance Eq A where+    (==) :: A -> A -> Bool+    (==) = _
+ plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensWithPragma where++data A+instance Eq A where+    (==) = _
+ plugins/hls-class-plugin/test/testdata/Inline.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE InstanceSigs #-}+module Inline where++data A+instance Eq A where (==) :: A -> A -> Bool+                    (==) = _
+ plugins/hls-class-plugin/test/testdata/Inline.hs view
@@ -0,0 +1,4 @@+module Inline where++data A+instance Eq A where (==) = _
+ plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE InstanceSigs #-}+module InsertPragmaOnce where++data A aaa+instance Applicative A where+  pure :: a -> A a+  pure = _+  (<*>) :: A (a -> b) -> A a -> A b+  (<*>) = _
+ plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.hs view
@@ -0,0 +1,4 @@+module InsertPragmaOnce where++data A aaa+instance Applicative A
+ plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021#-}+module InsertWithGHC2021Enabled where++data A+instance Eq A where+  (==) :: A -> A -> Bool+  (==) = _
+ plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GHC2021#-}+module InsertWithGHC2021Enabled where++data A+instance Eq A
+ plugins/hls-class-plugin/test/testdata/InsertWithPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithPragma where++data A+instance Eq A where+  (==) :: A -> A -> Bool+  (==) = _
+ plugins/hls-class-plugin/test/testdata/InsertWithPragma.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithPragma where++data A+instance Eq A
+ plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithoutPragma where++data A+instance Eq A where+  (==) :: A -> A -> Bool+  (==) = _
+ plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.hs view
@@ -0,0 +1,4 @@+module InsertWithoutPragma where++data A+instance Eq A
+ plugins/hls-class-plugin/test/testdata/LocalClassDefine.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE InstanceSigs #-}+module LocalClassDefine where++data A+class F a where+    f :: a -> Int++instance F A where+    f :: A -> Int+    f = _
+ plugins/hls-class-plugin/test/testdata/LocalClassDefine.hs view
@@ -0,0 +1,8 @@+module LocalClassDefine where++data A+class F a where+    f :: a -> Int++instance F A where+    f = _
+ plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs view
@@ -0,0 +1,6 @@+module MinimalDefinitionMeet where++data X = X++instance Eq X where+  (==) = _
+ plugins/hls-class-plugin/test/testdata/Qualified.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE InstanceSigs #-}+module Qualified where+import qualified QualifiedA++class F a where+    f :: a++instance F QualifiedA.A where+  f :: QualifiedA.A+  f = undefined
+ plugins/hls-class-plugin/test/testdata/Qualified.hs view
@@ -0,0 +1,8 @@+module Qualified where+import qualified QualifiedA++class F a where+    f :: a++instance F QualifiedA.A where+  f = undefined
+ plugins/hls-class-plugin/test/testdata/QualifiedA.hs view
@@ -0,0 +1,3 @@+module QualifiedA where++data A
+ plugins/hls-class-plugin/test/testdata/Stale.hs view
@@ -0,0 +1,5 @@+module Stale where++data A a+instance Functor A where+    fmap = _
+ plugins/hls-class-plugin/test/testdata/T1.all.expected.hs view
@@ -0,0 +1,7 @@+module T1 where++data X = X++instance Eq X where+  (==) = _+  (/=) = _
+ plugins/hls-class-plugin/test/testdata/T1.eq.expected.hs view
@@ -0,0 +1,6 @@+module T1 where++data X = X++instance Eq X where+  (==) = _
+ plugins/hls-class-plugin/test/testdata/T1.hs view
@@ -0,0 +1,5 @@+module T1 where++data X = X++instance Eq X where
+ plugins/hls-class-plugin/test/testdata/T1.ne.expected.hs view
@@ -0,0 +1,6 @@+module T1 where++data X = X++instance Eq X where+  (/=) = _
+ plugins/hls-class-plugin/test/testdata/T2.fmap.expected.hs view
@@ -0,0 +1,13 @@+module T2 where++data X a+  = A a+  | B++instance+  (Eq a) => Eq (X a)+ where++instance+  Functor X where+  fmap = _
+ plugins/hls-class-plugin/test/testdata/T2.hs view
@@ -0,0 +1,12 @@+module T2 where++data X a+  = A a+  | B++instance+  (Eq a) => Eq (X a)+ where++instance+  Functor X
+ plugins/hls-class-plugin/test/testdata/T3.1.expected.hs view
@@ -0,0 +1,13 @@+module T3 where++class Test a where+  f :: a+  f = h+  g :: a+  h :: a+  h = f+  {-# MINIMAL f, g | g, h #-}++instance Test [a] where+  f = _+  g = _
+ plugins/hls-class-plugin/test/testdata/T3.2.expected.hs view
@@ -0,0 +1,13 @@+module T3 where++class Test a where+  f :: a+  f = h+  g :: a+  h :: a+  h = f+  {-# MINIMAL f, g | g, h #-}++instance Test [a] where+  g = _+  h = _
+ plugins/hls-class-plugin/test/testdata/T3.hs view
@@ -0,0 +1,11 @@+module T3 where++class Test a where+  f :: a+  f = h+  g :: a+  h :: a+  h = f+  {-# MINIMAL f, g | g, h #-}++instance Test [a] where
+ plugins/hls-class-plugin/test/testdata/T4.expected.hs view
@@ -0,0 +1,8 @@+module T4 where++class Test a where+  _f :: a+  {-# MINIMAL _f #-}++instance Test Int where+  _f = _
+ plugins/hls-class-plugin/test/testdata/T4.hs view
@@ -0,0 +1,7 @@+module T4 where++class Test a where+  _f :: a+  {-# MINIMAL _f #-}++instance Test Int where
+ plugins/hls-class-plugin/test/testdata/T5.expected.hs view
@@ -0,0 +1,8 @@+module T1 where++data X = X++instance Eq X where+  (==) = _++x = ()
+ plugins/hls-class-plugin/test/testdata/T5.hs view
@@ -0,0 +1,7 @@+module T1 where++data X = X++instance Eq X where++x = ()
+ plugins/hls-class-plugin/test/testdata/T6.1.expected.hs view
@@ -0,0 +1,22 @@+module T6 where++data X = X | Y++class Test a where+  f :: a -> a+  f = h++  g :: a++  h :: a -> a+  h = f++  i :: a++  {-# MINIMAL f, g, i | g, h #-}++instance Test X where+  f X = X+  f Y = Y+  i = undefined+  g = _
+ plugins/hls-class-plugin/test/testdata/T6.2.expected.hs view
@@ -0,0 +1,23 @@+module T6 where++data X = X | Y++class Test a where+  f :: a -> a+  f = h++  g :: a++  h :: a -> a+  h = f++  i :: a++  {-# MINIMAL f, g, i | g, h #-}++instance Test X where+  f X = X+  f Y = Y+  i = undefined+  g = _+  h = _
+ plugins/hls-class-plugin/test/testdata/T6.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021#-}+module T6 where++data A+instance Eq A where+  (==) :: A -> A -> Bool+  (==) = _
+ plugins/hls-class-plugin/test/testdata/T6.hs view
@@ -0,0 +1,21 @@+module T6 where++data X = X | Y++class Test a where+  f :: a -> a+  f = h++  g :: a++  h :: a -> a+  h = f++  i :: a++  {-# MINIMAL f, g, i | g, h #-}++instance Test X where+  f X = X+  f Y = Y+  i = undefined
+ plugins/hls-class-plugin/test/testdata/TH.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}++module TH where++import THDef++gen ''Bool True+gen ''Char 'a'
+ plugins/hls-class-plugin/test/testdata/THDef.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}++module THDef where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++class F a where+    f :: a++gen :: Lift t => Name -> t -> Q [Dec]+gen ty v = [d| instance F $(conT ty) where f = v |]
+ plugins/hls-class-plugin/test/testdata/Ticket3942one.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DeriveAnyClass #-}++module Ticket3942one where++class C a where+  foo :: a -> Int++newtype Foo = MkFoo Int deriving (C)+instance Show Foo where+++main :: IO ()+main = return ()
+ plugins/hls-class-plugin/test/testdata/TypeFamily.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+module TypeFamily where++class F a where+  type Elem a+  f :: Elem a -> a++instance Eq a => F [a] where+  f :: Eq a => Elem [a] -> [a]+  f = _
+ plugins/hls-class-plugin/test/testdata/TypeFamily.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies #-}+module TypeFamily where++class F a where+  type Elem a+  f :: Elem a -> a++instance Eq a => F [a] where+  f = _
+ plugins/hls-class-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: [-XHaskell2010, QualifiedA, THDef]
+ plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+module Ide.Plugin.CodeRange (+    descriptor+    , Log++    -- * Internal+    , findPosition+    , findFoldingRanges+    , createFoldingRange+    ) where++import           Control.Monad.IO.Class               (MonadIO (liftIO))+import           Control.Monad.Trans.Except           (ExceptT, mapExceptT)+import           Control.Monad.Trans.Maybe            (MaybeT (MaybeT),+                                                       maybeToExceptT)+import           Data.List.Extra                      (drop1)+import           Data.Maybe                           (fromMaybe)+import           Data.Vector                          (Vector)+import qualified Data.Vector                          as V+import           Development.IDE                      (Action,+                                                       IdeState (shakeExtras),+                                                       Range (Range), Recorder,+                                                       WithPriority,+                                                       cmapWithPrio)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (PositionMapping,+                                                       toCurrentRange)+import           Ide.Logger                           (Pretty (..))+import           Ide.Plugin.CodeRange.Rules           (CodeRange (..),+                                                       GetCodeRange (..),+                                                       codeRangeRule, crkToFrk)+import qualified Ide.Plugin.CodeRange.Rules           as Rules (Log)+import           Ide.Plugin.Error+import           Ide.PluginUtils                      (positionInRange)+import           Ide.Types                            (PluginDescriptor (pluginHandlers, pluginRules),+                                                       PluginId,+                                                       PluginMethodHandler,+                                                       defaultPluginDescriptor,+                                                       mkPluginHandler)+import           Language.LSP.Protocol.Message        (Method (Method_TextDocumentFoldingRange, Method_TextDocumentSelectionRange),+                                                       SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange))+import           Language.LSP.Protocol.Types          (FoldingRange (..),+                                                       FoldingRangeParams (..),+                                                       NormalizedFilePath, Null,+                                                       Position (..),+                                                       Range (_start),+                                                       SelectionRange (..),+                                                       SelectionRangeParams (..),+                                                       TextDocumentIdentifier (TextDocumentIdentifier),+                                                       Uri, type (|?) (InL))+import           Prelude                              hiding (log, span)++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId "Provides selection and folding ranges for Haskell")+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentSelectionRange (selectionRangeHandler recorder)+    <> mkPluginHandler SMethod_TextDocumentFoldingRange (foldingRangeHandler recorder)+    , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder)+    }++newtype Log = LogRules Rules.Log++instance Pretty Log where+    pretty (LogRules codeRangeLog) = pretty codeRangeLog+++foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange+foldingRangeHandler _ ide _ FoldingRangeParams{..} =+    do+        filePath <- getNormalizedFilePathE uri+        foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath+        pure . InL $ foldingRanges+  where+    uri :: Uri+    TextDocumentIdentifier uri = _textDocument++getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange]+getFoldingRanges file = do+    codeRange <- useE GetCodeRange file+    pure $ findFoldingRanges codeRange++selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange+selectionRangeHandler _ ide _ SelectionRangeParams{..} = do+   do+        filePath <- getNormalizedFilePathE uri+        mapExceptT liftIO $ getSelectionRanges ide filePath positions+  where+    uri :: Uri+    TextDocumentIdentifier uri = _textDocument++    positions :: [Position]+    positions = _positions+++getSelectionRanges :: IdeState -> NormalizedFilePath -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null)+getSelectionRanges ide file positions = do+    (codeRange, positionMapping) <- runIdeActionE "SelectionRange" (shakeExtras ide) $ useWithStaleFastE GetCodeRange file+    -- 'positionMapping' should be applied to the input before using them+    positions' <-+        traverse (fromCurrentPositionE positionMapping) positions++    let selectionRanges = flip fmap positions' $ \pos ->+            -- We need a default selection range if the lookup fails,+            -- so that other positions can still have valid results.+            let defaultSelectionRange = SelectionRange (Range pos pos) Nothing+             in fromMaybe defaultSelectionRange . findPosition pos $ codeRange++    -- 'positionMapping' should be applied to the output ranges before returning them+    maybeToExceptT (PluginInvalidUserState "toCurrentSelectionRange") . MaybeT . pure $+        InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges++-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'.+findPosition :: Position -> CodeRange -> Maybe SelectionRange+findPosition pos root = go Nothing root+  where+    -- Helper function for recursion. The range list is built top-down+    go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange+    go acc node =+        if positionInRange pos range+        then maybe acc' (go acc') (binarySearchPos children)+        -- If all children doesn't contain pos, acc' will be returned.+        -- acc' will be Nothing only if we are in the root level.+        else Nothing+      where+        range = _codeRange_range node+        children = _codeRange_children node+        acc' = Just $ maybe (SelectionRange range Nothing) (SelectionRange range . Just) acc++    binarySearchPos :: Vector CodeRange -> Maybe CodeRange+    binarySearchPos v+        | V.null v = Nothing+        | V.length v == 1,+            Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing+        | otherwise = do+            let (left, right) = V.splitAt (V.length v `div` 2) v+            startOfRight <- _start . _codeRange_range <$> V.headM right+            if pos < startOfRight then binarySearchPos left else binarySearchPos right++-- | Traverses through the code range and it children to a folding ranges.+--+-- It starts with the root node, converts that into a folding range then moves towards the children.+-- It converts each child of each root node and parses it to folding range and moves to its children.+--+-- Two cases to that are assumed to be taken care on the client side are:+--+--      1. When a folding range starts and ends on the same line, it is upto the client if it wants to+--      fold a single line folding or not.+--+--      2. As we are converting nodes of the ast into folding ranges, there are multiple nodes starting from a single line.+--      A single line of code doesn't mean a single node in AST, so this function removes all the nodes that have a duplicate+--      start line, ie. they start from the same line.+--      Eg. A multi-line function that also has a multi-line if statement starting from the same line should have the folding+--      according to the function.+--+-- We think the client can handle this, if not we could change to remove these in future+--+-- Discussion reference: https://github.com/haskell/haskell-language-server/pull/3058#discussion_r973737211+findFoldingRanges :: CodeRange -> [FoldingRange]+findFoldingRanges codeRange =+    -- removing the first node because it folds the entire file+    drop1 $ findFoldingRangesRec codeRange++findFoldingRangesRec :: CodeRange -> [FoldingRange]+findFoldingRangesRec r@(CodeRange _ children _) =+    let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRangesRec children+    in case createFoldingRange r of+        Just x  -> x:frChildren+        Nothing -> frChildren++-- | Parses code range to folding range+createFoldingRange :: CodeRange -> Maybe FoldingRange+createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do+    -- Type conversion of codeRangeKind to FoldingRangeKind+    let frk = crkToFrk ck+    Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk) Nothing)++-- | Likes 'toCurrentPosition', but works on 'SelectionRange'+toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange+toCurrentSelectionRange positionMapping SelectionRange{..} = do+    newRange <- toCurrentRange positionMapping _range+    pure $ SelectionRange {+        _range = newRange,+        _parent = _parent >>= toCurrentSelectionRange positionMapping+    }
+ plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.CodeRange.ASTPreProcess+    ( preProcessAST+    , PreProcessEnv(..)+    , isCustomNode+    , CustomNodeType(..)+    ) where++import           Control.Monad.Reader       (Reader, asks)+import           Data.Foldable+import           Data.Functor.Identity      (Identity (Identity, runIdentity))+import           Data.List                  (groupBy)+import           Data.List.NonEmpty         (NonEmpty)+import qualified Data.List.NonEmpty         as NonEmpty+import           Data.Map.Strict            (Map)+import qualified Data.Map.Strict            as Map+import           Data.Maybe                 (fromMaybe, mapMaybe)+import           Data.Semigroup             (First (First, getFirst))+import           Data.Semigroup.Foldable    (foldlM1)+import qualified Data.Set                   as Set+import           Development.IDE.GHC.Compat hiding (nodeInfo)+import           Prelude                    hiding (span)++{-|+Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context+-}+newtype PreProcessEnv a = PreProcessEnv+    { preProcessEnvRefMap :: RefMap a+    }++{-|+Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies+the AST to handle some special cases.++'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as+a concrete example example.++Adding another manipulation to the AST is simple, just implement a function of type+`HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`.++If it goes more complex, it may be more appropriate to split different manipulations to different modules.+-}+preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a)+preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition++{-|+Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST'+provided by GHC, but created to suite the needs of hls-code-range-plugin.+-}+createCustomNode :: CustomNodeType -> NonEmpty (HieAST a) -> HieAST a+createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEmpty.toList children)+  where+    span' :: RealSrcSpan+    span' = runIdentity . foldlM1 (\x y -> Identity (combineRealSrcSpans x y)) . fmap nodeSpan $ children++    customNodeInfo = simpleNodeInfoCompat "HlsCustom" (customNodeTypeToFastString customNodeType)++isCustomNode :: HieAST a -> Maybe CustomNodeType+isCustomNode node = do+    nodeInfo <- generatedNodeInfo node+    getFirst <$> foldMap go (nodeAnnotations nodeInfo)+  where+    go :: (FastStringCompat, FastStringCompat) -> Maybe (First CustomNodeType)+    go (k, v)+        | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v')+        | otherwise = Nothing++data CustomNodeType =+    -- | a group of imports+    CustomNodeImportsGroup+    -- | adjacent type signature and value definition are paired under a custom parent node+  | CustomNodeAdjacentSignatureDefinition+    deriving (Show, Eq, Ord)++customNodeTypeMapping :: Map CustomNodeType FastStringCompat+customNodeTypeMapping = Map.fromList+    [ (CustomNodeImportsGroup, "Imports")+    , (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition")+    ]++revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType+revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList $ customNodeTypeMapping++customNodeTypeToFastString :: CustomNodeType -> FastStringCompat+customNodeTypeToFastString k = fromMaybe "" (customNodeTypeMapping Map.!? k)++{-|+Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting+the whole import area while expanding/shrinking the selection range.+-}+mergeImports :: forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a)+mergeImports node = pure $ node { nodeChildren = children }+  where+    children :: [HieAST a]+    children = mapMaybe merge+        . groupBy (\x y -> nodeIsImport x && nodeIsImport y)+        . nodeChildren $ node++    merge :: [HieAST a] -> Maybe (HieAST a)+    merge []     = Nothing+    merge [x]    = Just x+    merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs)++nodeIsImport :: HieAST a -> Bool+nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl")++{-|+Combine type signature with variable definition under a new parent node, if the signature is placed right before the+definition. This allows the user to have a step selecting both type signature and its accompanying definition.+-}+mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a)+mergeSignatureWithDefinition node = do+    refMap <- asks preProcessEnvRefMap+    -- Do this recursively for children, so that non top level functions can be handled.+    children' <- traverse mergeSignatureWithDefinition (nodeChildren node)+    pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' }+  where+    -- For every two adjacent nodes, we try to combine them into one.+    go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a]+    go _ [] node' = [node']+    go refMap (prev:others) node' =+        case mergeAdjacentSigDef refMap (prev, node') of+            Nothing   -> node':prev:others+            Just comb -> comb:others++-- | Merge adjacent type signature and variable/function definition, if the type signature belongs to that variable or+-- function.+--+-- The implementation potentially has some corner cases not handled properly.+mergeAdjacentSigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a)+mergeAdjacentSigDef refMap (n1, n2) = do+    -- Let's check the node's annotation. There should be a function binding following its type signature.+    checkAnnotation+    -- Find the identifier of the type signature.+    typeSigId <- identifierForTypeSig n1+    -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes.+    refs <- Map.lookup typeSigId refMap+    if any (isIdentADef (nodeSpan n2)) refs+    then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2]+    else Nothing+  where+    checkAnnotation :: Maybe ()+    checkAnnotation =+      if ("TypeSig", "Sig") `isAnnotationInAstNode` n1 &&+         (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2)+      then Just ()+      else Nothing++{-|+Given the AST node of a type signature, tries to find the identifier of it.+-}+identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier+identifierForTypeSig node =+    {-+        It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in+        its children recursively.+    -}+    case mapMaybe extractIdentifier nodes of+      []        -> Nothing+      (ident:_) -> Just ident+  where+    nodes = flattenAst node++    extractIdentifier :: HieAST a -> Maybe Identifier+    extractIdentifier node' = sourceNodeInfo node' >>=+        (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail)+        . Map.toList . nodeIdentifiers)++-- | Determines if the given occurrence of an identifier is a function/variable definition in the outer span+isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool+isIdentADef outerSpan (span, detail) =+    realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan+    && isDef+  where+    isDef :: Bool+    isDef = any isContextInfoDef . toList . identInfo $ detail++    -- Determines if the 'ContextInfo' represents a variable/function definition+    isContextInfoDef :: ContextInfo -> Bool+    isContextInfoDef ValBind{} = True+    isContextInfoDef MatchBind = True+    isContextInfoDef _         = False++isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool+isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo
+ plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-}++module Ide.Plugin.CodeRange.Rules+    ( CodeRange (..)+    , codeRange_range+    , codeRange_children+    , codeRange_kind+    , CodeRangeKind(..)+    , GetCodeRange(..)+    , codeRangeRule+    , Log(..)++    -- * Internal+    , removeInterleaving+    , simplify+    , crkToFrk+    ) where++import           Control.DeepSeq                    (NFData)+import qualified Control.Lens                       as Lens+import           Control.Monad                      (foldM)+import           Control.Monad.Except               (ExceptT (..), runExceptT)+import           Control.Monad.Reader               (runReader)+import           Control.Monad.Trans.Class          (lift)+import           Control.Monad.Trans.Maybe          (MaybeT (MaybeT),+                                                     maybeToExceptT)+import           Control.Monad.Trans.Writer.CPS+import           Data.Coerce                        (coerce)+import           Data.Data                          (Typeable)+import           Data.Foldable                      (traverse_)+import           Data.Function                      (on, (&))+import           Data.Hashable+import           Data.List                          (sort)+import qualified Data.Map.Strict                    as Map+import           Data.Vector                        (Vector)+import qualified Data.Vector                        as V+import           Development.IDE+import           Development.IDE.Core.Rules         (toIdeResult)+import qualified Development.IDE.Core.Shake         as Shake+import           Development.IDE.GHC.Compat         (HieAST (..),+                                                     HieASTs (getAsts), RefMap)+import           Development.IDE.GHC.Compat.Util+import           GHC.Generics                       (Generic)+import           Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..),+                                                     PreProcessEnv (..),+                                                     isCustomNode,+                                                     preProcessAST)+import           Language.LSP.Protocol.Types        (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region))++import           Language.LSP.Protocol.Lens         (HasEnd (end),+                                                     HasStart (start))+import           Prelude                            hiding (log)++data Log = LogShake Shake.Log+    | LogNoAST+    | LogFoundInterleaving CodeRange CodeRange+      deriving Show++instance Pretty Log where+    pretty log = case log of+        LogShake shakeLog -> pretty shakeLog+        LogNoAST          -> "no HieAst exist for file"+        LogFoundInterleaving r1 r2 ->+            let prettyRange = pretty . show . _codeRange_range+             in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2++-- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range+data CodeRange = CodeRange {+    -- | Range for current level+        _codeRange_range    :: !Range,+    -- | A vector of children, sorted by their ranges in ascending order.+    -- Children are guaranteed not to interleave, but some gaps may exist among them.+        _codeRange_children :: !(Vector CodeRange),+    -- The kind of current code range+        _codeRange_kind     :: !CodeRangeKind+    }+    deriving (Show, Generic, NFData)++-- | 'CodeKind' represents the kind of a code range+data CodeRangeKind =+    -- | ordinary code+    CodeKindRegion+    -- | the group of imports+  | CodeKindImports+  -- | a comment+  | CodeKindComment+    deriving (Show, Eq, Generic, NFData)++Lens.makeLenses ''CodeRange++instance Eq CodeRange where+    (==) = (==) `on` _codeRange_range++instance Ord CodeRange where+    compare :: CodeRange -> CodeRange -> Ordering+    compare = compare `on` _codeRange_range++-- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong,+-- a list of warnings will be returned as 'Log'+buildCodeRange :: HieAST a -> RefMap a -> Writer [Log] CodeRange+buildCodeRange ast refMap = do+    -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding+    -- range don't need to care about 'HieAST'+    -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments)+    let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap)+    codeRange <- astToCodeRange ast'+    pure $ simplify codeRange++astToCodeRange :: HieAST a -> Writer [Log] CodeRange+astToCodeRange (Node _ sp []) = pure $ CodeRange (realSrcSpanToRange sp) mempty CodeKindRegion+astToCodeRange node@(Node _ sp children) = do+    children' <- removeInterleaving . sort =<< traverse astToCodeRange children+    let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion+    pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind++-- | Remove interleaving of the list of 'CodeRange's.+removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange]+removeInterleaving = fmap reverse . foldM go []+  where+    -- we want to traverse from left to right (to make the logs easier to read)+    go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange]+    go [] x = pure [x]+    go (x1:acc) x2 = do+        -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range+        -- compares it's start position first, the start position must be already in an ascending order.+        -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving+        -- must exist.+        -- (Note: LSP Range's end position is exclusive)+        x1' <- if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start+            then do+                -- set x1.end to x2.start+                let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start)+                tell [LogFoundInterleaving x1 x2]+                pure x1'+            else pure x1+        pure $ x2:x1':acc++-- | Remove redundant nodes in 'CodeRange' tree+simplify :: CodeRange -> CodeRange+simplify r =+    case onlyChild of+        -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed.+        Just onlyChild' ->+            if _codeRange_range onlyChild' == curRange+            then simplify (r { _codeRange_children = _codeRange_children onlyChild' })+            else withChildrenSimplified+        Nothing -> withChildrenSimplified+  where+    curRange = _codeRange_range r++    onlyChild :: Maybe CodeRange =+        let children = _codeRange_children r+         in if V.length children == 1 then V.headM children else Nothing++    withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r }++data GetCodeRange = GetCodeRange+    deriving (Eq, Show, Typeable, Generic)++instance Hashable GetCodeRange+instance NFData   GetCodeRange++type instance RuleResult GetCodeRange = CodeRange++codeRangeRule :: Recorder (WithPriority Log) -> Rules ()+codeRangeRule recorder =+    define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do+        -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords).+        -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations+        HAR{hieAst, refMap} <- lift $ use_ GetHieAst file+        ast <- maybeToExceptT LogNoAST . MaybeT . pure $+            getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file+        let (codeRange, warnings) = runWriter (buildCodeRange ast refMap)+        traverse_ (logWith recorder Warning) warnings++        pure codeRange++-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)+handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)+handleError recorder action' = do+    valueEither <- runExceptT action'+    case valueEither of+        Left msg -> do+            logWith recorder Warning msg+            pure $ toIdeResult (Left [])+        Right value -> pure $ toIdeResult (Right value)++-- | Maps type CodeRangeKind to FoldingRangeKind+crkToFrk :: CodeRangeKind -> FoldingRangeKind+crkToFrk crk = case crk of+        CodeKindComment -> FoldingRangeKind_Comment+        CodeKindImports -> FoldingRangeKind_Imports+        CodeKindRegion  -> FoldingRangeKind_Region
+ plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedLists #-}++module Ide.Plugin.CodeRange.RulesTest (testTree) where++import           Control.Monad.Trans.Writer.CPS+import           Data.Bifunctor                 (Bifunctor (second))+import qualified Data.Vector                    as V+import           Ide.Plugin.CodeRange.Rules+import           Test.Hls++testTree :: TestTree+testTree =+    testGroup "CodeRange.Rules" [+        testGroup "removeInterleaving" $+            let check :: [CodeRange] -> ([CodeRange], [Log]) -> Assertion+                check input want =+                    second (fmap LogEq) (runWriter (removeInterleaving input)) @?= second (fmap LogEq) want+                mkNode :: UInt -> UInt -> CodeRange+                mkNode startCol endCol =+                    CodeRange (Range (Position 1 startCol) (Position 1 endCol)) [] CodeKindRegion+            in [+                testCase "empty list" $ check [] ([], []),+                testCase "one" $ check [mkNode 1 5] ([mkNode 1 5], []),+                testCase "two, without intersection" $ check [mkNode 1 5, mkNode 5 6] ([mkNode 1 5, mkNode 5 6], []),+                testCase "two, with intersection" $ let (x, y) = (mkNode 1 5, mkNode 2 4)+                    in check [x, y] ([mkNode 1 2, mkNode 2 4], [LogFoundInterleaving x y]),+                testCase "three, with intersection" $ let (x, y, z) = (mkNode 1 10, mkNode 2 6, mkNode 4 12)+                    in check [x, y, z] ([mkNode 1 2, mkNode 2 4, mkNode 4 12],+                        [LogFoundInterleaving x y, LogFoundInterleaving y z])+            ],+        testGroup "simplify" $+            let mkNode :: UInt -> UInt -> V.Vector CodeRange -> CodeRange+                mkNode startCol endCol children =+                    CodeRange (Range (Position 1 startCol) (Position 1 endCol)) children CodeKindRegion+            in [+                testCase "one level should not change" $+                    let codeRange = mkNode 1 5 []+                     in codeRange @=? simplify codeRange,+                testCase "dedup 3 nested layers" $+                    let input =+                            mkNode 1 10 [+                                mkNode 1 5 [],+                                mkNode 5 10 [+                                    mkNode 5 10 [+                                        mkNode 5 10 [+                                            mkNode 6 10 []+                                        ]+                                    ]+                                ]+                            ]+                        want =+                            mkNode 1 10 [+                                mkNode 1 5 [],+                                mkNode 5 10 [+                                    mkNode 6 10 []+                                ]+                            ]+                     in want @=? simplify input,+                testCase "should not dedup node that has multiple children" $+                    let input =+                            mkNode 1 10 [+                                mkNode 1 10 [],+                                mkNode 2 10 []+                            ]+                     in simplify input @?= input,+                testCase "dedup simple two layers" $+                    let input = mkNode 1 10 [ mkNode 1 10 []]+                     in simplify input @?= mkNode 1 10 []+            ]+    ]++newtype LogEq = LogEq Log+    deriving Show++instance Eq LogEq where+    LogEq (LogShake _) == LogEq (LogShake _) = True+    LogEq LogNoAST == LogEq LogNoAST = True+    LogEq (LogFoundInterleaving left right) == LogEq (LogFoundInterleaving left' right') =+        left == left' && right == right'+    LogEq _ == LogEq _ = False
+ plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedLists #-}++module Ide.Plugin.CodeRangeTest (testTree) where++import qualified Data.Vector                as V+import           Ide.Plugin.CodeRange+import           Ide.Plugin.CodeRange.Rules+import           Test.Hls++testTree :: TestTree+testTree =+    testGroup "CodeRange" [+        testGroup "findPosition" $+            let check :: Position -> CodeRange -> Maybe SelectionRange -> Assertion+                check position codeRange = (findPosition position codeRange @?=)++                mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange+                mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion+            in [+                testCase "not in range" $ check+                    (Position 10 1)+                    (mkCodeRange (Position 1 1) (Position 5 10) [])+                    Nothing,+                testCase "in top level range" $ check+                    (Position 3 8)+                    (mkCodeRange (Position 1 1) (Position 5 10) [])+                    (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing),+                testCase "in the gap between children, in parent" $ check+                    (Position 3 6)+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 1) (Position 3 6) [],+                        mkCodeRange (Position 3 7) (Position 5 10) []+                    ])+                    (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing),+                testCase "before all children, in parent" $ check+                    (Position 1 1)+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [],+                        mkCodeRange (Position 3 7) (Position 5 10) []+                    ])+                    (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing),+                testCase "in children, in parent" $ check+                    (Position 2 1)+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [],+                        mkCodeRange (Position 3 7) (Position 5 10) []+                    ])+                    (Just $ SelectionRange (Range (Position 1 2) (Position 3 6)) $ Just+                        ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing+                        )+                    )+            ],++        -- TODO: Some more tests can be added on strange cases like+        -- 1. lots of blank lines in between type signature and the body+        -- 2. lots of blank lines in the function itself+        -- etc.+        testGroup "findFoldingRanges" $+            let check :: CodeRange -> [FoldingRange] -> Assertion+                check codeRange = (findFoldingRanges codeRange @?=)++                mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange+                mkCodeRange start end children crk = CodeRange (Range start end) children crk+            in [+                -- General test+                testCase "Test General Code Block" $ check+                    (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion)+                    [],++                -- Tests for code kind+                testCase "Test Code Kind Region" $ check+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion+                    ] CodeKindRegion)+                    [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing],+                testCase "Test Code Kind Comment" $ check+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment+                    ] CodeKindRegion)+                    [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Comment) Nothing],+                testCase "Test Code Kind Import" $ check+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports+                    ] CodeKindRegion)+                    [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Imports) Nothing],++                -- Test for Code Portions with children+                testCase "Test Children" $ check+                    (mkCodeRange (Position 1 1) (Position 5 10) [+                        mkCodeRange (Position 1 2) (Position 3 6) [+                            mkCodeRange (Position 1 3) (Position 1 5) [] CodeKindRegion+                        ] CodeKindRegion,+                        mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion+                    ] CodeKindRegion)+                    [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing,+                        FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeKind_Region) Nothing,+                        FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing+                    ]+            ],++        testGroup "createFoldingRange" $+        let check :: CodeRange -> Maybe FoldingRange -> Assertion+            check codeRange = (createFoldingRange codeRange @?=)++            mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange+            mkCodeRange start end children crk = CodeRange (Range start end) children crk+        in [+            -- General tests+            testCase "Test General Code Block" $ check+                (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion)+                (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing)),+            -- If a range has the same start and end line it need not be folded so Nothing is expected+            testCase "Test Same Start Line" $ check+                (mkCodeRange (Position 1 1) (Position 1 10) [] CodeKindRegion)+                (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeKind_Region) Nothing))+        ]+    ]
+ plugins/hls-code-range-plugin/test/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import           Control.Lens                   hiding (List, (<.>))+import           Data.ByteString.Lazy           (ByteString)+import qualified Data.ByteString.Lazy.Char8     as LBSChar8+import           Data.String                    (fromString)+import           Ide.Plugin.CodeRange           (Log, descriptor)+import qualified Ide.Plugin.CodeRange.RulesTest+import qualified Ide.Plugin.CodeRangeTest+import           Language.LSP.Protocol.Lens     (result)+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           System.FilePath                ((<.>), (</>))+import           Test.Hls++plugin :: PluginTestDescriptor Log+plugin = mkPluginTestDescriptor descriptor "codeRange"++main :: IO ()+main = do+    defaultTestRunner $+        testGroup "Code Range" [+            testGroup "Integration Tests" [+                selectionRangeGoldenTest "Import" [(4, 36), (1, 8)],+                selectionRangeGoldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)],+                selectionRangeGoldenTest "Empty" [(1, 5)],+                foldingRangeGoldenTest "Function"+            ],+            testGroup "Unit Tests" [+                Ide.Plugin.CodeRangeTest.testTree,+                Ide.Plugin.CodeRange.RulesTest.testTree+            ]+        ]++selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree+selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do+    res <- runSessionWithServer def plugin testDataDir $ do+        doc <- openDoc (testName <.> "hs") "haskell"+        resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc+            $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions+        let res = resp ^. result+        pure $ fmap (showSelectionRangesForTest . absorbNull) res+    case res of+        Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure ""+        Left err     -> assertFailure (show err)+        Right golden -> pure golden+  where+    testDataDir :: FilePath+    testDataDir = "plugins" </> "hls-code-range-plugin" </> "test" </> "testdata" </> "selection-range"++    showSelectionRangesForTest :: [SelectionRange] -> ByteString+    showSelectionRangesForTest selectionRanges = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges++    showSelectionRangeForTest :: SelectionRange -> ByteString+    showSelectionRangeForTest selectionRange = go True (Just selectionRange)+      where+        go :: Bool -> Maybe SelectionRange -> ByteString+        go _ Nothing = ""+        go isFirst (Just (SelectionRange (Range sp ep) parent)) =+            (if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent+        showPosition :: Position -> ByteString+        showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")"+        showLBS = fromString . show++foldingRangeGoldenTest :: TestName -> TestTree+foldingRangeGoldenTest testName = goldenGitDiff  testName (testDataDir </> testName <.> "golden" <.> "txt") $ do+    res <- runSessionWithServer def plugin testDataDir $ do+        doc <- openDoc (testName <.> "hs") "haskell"+        resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc+        let res = resp ^. result+        pure $ fmap (showFoldingRangesForTest . absorbNull) res++    case res of+        Left err     -> assertFailure (show err)+        Right golden -> pure golden++    where+        testDataDir :: FilePath+        testDataDir = "plugins" </> "hls-code-range-plugin" </> "test" </> "testdata" </> "folding-range"++        showFoldingRangesForTest :: [FoldingRange] -> ByteString+        showFoldingRangesForTest foldingRanges = (LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges) `LBSChar8.snoc` '\n'++        showFoldingRangeForTest :: FoldingRange -> ByteString+        showFoldingRangeForTest (FoldingRange sl (Just sc) el (Just ec) (Just frk) _) =+            "((" <> showLBS sl <> ", " <> showLBS sc <> ") : (" <> showLBS el <> ", " <> showLBS ec <> ")) : " <> showFRK frk+        showFoldingRangeForTest fr =+            "unexpected FoldingRange: " <> fromString (show fr)++        showLBS = fromString . show+        showFRK = fromString . show
+ plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt view
+ plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs view
@@ -0,0 +1,1 @@+module Empty where
+ plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt view
@@ -0,0 +1,41 @@+((2, 16) : (2, 22)) : FoldingRangeKind_Region+((4, 0) : (7, 21)) : FoldingRangeKind_Region+((4, 0) : (4, 25)) : FoldingRangeKind_Region+((4, 0) : (4, 6)) : FoldingRangeKind_Region+((4, 10) : (4, 25)) : FoldingRangeKind_Region+((4, 10) : (4, 17)) : FoldingRangeKind_Region+((4, 21) : (4, 25)) : FoldingRangeKind_Region+((5, 0) : (7, 21)) : FoldingRangeKind_Region+((5, 0) : (5, 6)) : FoldingRangeKind_Region+((5, 7) : (5, 8)) : FoldingRangeKind_Region+((5, 9) : (7, 21)) : FoldingRangeKind_Region+((5, 11) : (7, 21)) : FoldingRangeKind_Region+((5, 14) : (5, 28)) : FoldingRangeKind_Region+((5, 14) : (5, 23)) : FoldingRangeKind_Region+((5, 14) : (5, 15)) : FoldingRangeKind_Region+((5, 16) : (5, 21)) : FoldingRangeKind_Region+((5, 22) : (5, 23)) : FoldingRangeKind_Region+((5, 24) : (5, 26)) : FoldingRangeKind_Region+((5, 27) : (5, 28)) : FoldingRangeKind_Region+((6, 16) : (6, 20)) : FoldingRangeKind_Region+((7, 16) : (7, 21)) : FoldingRangeKind_Region+((9, 0) : (12, 20)) : FoldingRangeKind_Region+((9, 0) : (9, 24)) : FoldingRangeKind_Region+((9, 0) : (9, 5)) : FoldingRangeKind_Region+((9, 9) : (9, 24)) : FoldingRangeKind_Region+((9, 9) : (9, 16)) : FoldingRangeKind_Region+((9, 20) : (9, 24)) : FoldingRangeKind_Region+((10, 0) : (12, 20)) : FoldingRangeKind_Region+((10, 0) : (10, 5)) : FoldingRangeKind_Region+((10, 6) : (10, 7)) : FoldingRangeKind_Region+((10, 8) : (12, 20)) : FoldingRangeKind_Region+((10, 10) : (12, 20)) : FoldingRangeKind_Region+((10, 13) : (10, 27)) : FoldingRangeKind_Region+((10, 13) : (10, 22)) : FoldingRangeKind_Region+((10, 13) : (10, 14)) : FoldingRangeKind_Region+((10, 15) : (10, 20)) : FoldingRangeKind_Region+((10, 21) : (10, 22)) : FoldingRangeKind_Region+((10, 23) : (10, 25)) : FoldingRangeKind_Region+((10, 26) : (10, 27)) : FoldingRangeKind_Region+((11, 16) : (11, 21)) : FoldingRangeKind_Region+((12, 16) : (12, 20)) : FoldingRangeKind_Region
+ plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use module export list" #-}+module Function(isEven) where++isEven :: Integer -> Bool+isEven n = if n `mod` 2 == 0+           then True+           else False++isOdd :: Integer -> Bool+isOdd n = if n `mod` 2 == 0+           then False+           else True
+ plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments:+      - "Function"+      - "Empty"
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt view
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs view
@@ -0,0 +1,1 @@+module Empty where
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt view
@@ -0,0 +1,4 @@+(5,16) (5,20) => (5,16) (5,40) => (5,14) (11,20) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(5,12) (5,13) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(4,1) (4,9) => (4,1) (4,29) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(3,1) (3,9) => (3,1) (3,61) => (3,1) (11,20) => (3,1) (14,15)
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs view
@@ -0,0 +1,14 @@+module FuncMultiMatch where++someFunc :: Integral a => a -> String -> Maybe (Int, String)+someFunc _ "magic" = Nothing+someFunc x y = Just (fromIntegral x, y)+  where+    go :: Int -> Int+    go 0 = -1+    go x = x + 1++    hi = "greeting"++otherFunc :: String -> String+otherFunc = id
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt view
@@ -0,0 +1,2 @@+(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47)+(1,8) (1,8)
+ plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs view
@@ -0,0 +1,4 @@+module MultiPositions where++import Data.List (find)+import qualified Data.Foldable (foldl, foldl')
+ plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml view
@@ -0,0 +1,6 @@+cradle:+  direct:+    arguments:+      - "Import"+      - "Function"+      - "Empty"
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE LambdaCase            #-}++{- |+Eval Plugin entry point.+-}+module Ide.Plugin.Eval (+    descriptor,+    Log(..)+    ) where++import           Development.IDE               (IdeState)+import           Ide.Logger                    (Pretty (pretty), Recorder,+                                                WithPriority, cmapWithPrio)+import qualified Ide.Plugin.Eval.CodeLens      as CL+import           Ide.Plugin.Eval.Config+import           Ide.Plugin.Eval.Rules         (rules)+import qualified Ide.Plugin.Eval.Rules         as EvalRules+import           Ide.Types                     (ConfigDescriptor (..),+                                                PluginDescriptor (..), PluginId,+                                                defaultConfigDescriptor,+                                                defaultPluginDescriptor,+                                                mkCustomConfig, mkPluginHandler)+import           Language.LSP.Protocol.Message++newtype Log = LogEvalRules EvalRules.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogEvalRules log -> pretty log++-- |Plugin descriptor+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+    (defaultPluginDescriptor plId "Provies a code lens to evaluate expressions in doctest comments")+        { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens+        , pluginCommands = [CL.evalCommand plId]+        , pluginRules = rules (cmapWithPrio LogEvalRules recorder)+        , pluginConfigDescriptor = defaultConfigDescriptor+                                   { configCustomConfig = mkCustomConfig properties+                                   }+        }
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}+{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}++-- | Expression execution+module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, 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           GHC                         (ExecOptions, ExecResult (..),+                                              execStmt)+import           Ide.Plugin.Eval.Types       (Language (Plain), Loc,+                                              Located (..),+                                              Section (sectionLanguage),+                                              Test (..), Txt, locate, locate0)+import qualified Language.LSP.Protocol.Lens  as L+import           Language.LSP.Protocol.Types (Position (Position),+                                              Range (Range))+import           System.IO.Extra             (newTempFile, readFile')++-- | Return the ranges of the expression and result parts of the given test+testRanges :: Test -> (Range, Range)+testRanges tst =+    let startLine = testRange tst ^. L.start . L.line+        (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst+        resLine = startLine + exprLines+     in ( Range+            (Position startLine 0)+            --(Position (startLine + exprLines + resultLines) 0),+            (Position resLine 0)+        , Range (Position resLine 0) (Position (resLine + resultLines) 0)+        )++{- |The document range where a test is defined+ testRange :: Loc Test -> Range+ testRange = fst . testRanges+-}++-- |The document range where the result of the test is defined+resultRange :: Test -> Range+resultRange = snd . testRanges++-- TODO: handle BLANKLINE+{-+>>> showDiffs $  getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"]+["abc","def","WAS ghi","NOW Z","NOW ZZ","end"]+-}+showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a]+showDiffs = map showDiff++showDiff :: (Semigroup a, IsString a) => Diff a -> a+showDiff (First w)  = "WAS " <> w+showDiff (Second w) = "NOW " <> w+showDiff (Both w _) = w++testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text]+testCheck diff (section, test) out+    | not diff || null (testOutput test) || sectionLanguage section == Plain = out+    | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out++testLengths :: Test -> (Int, Int)+testLengths (Example e r _)  = (NE.length e, length r)+testLengths (Property _ r _) = (1, length r)++-- |A one-line Haskell statement+type Statement = Loc String++asStatements :: Test -> [Statement]+asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. L.start . L.line) (asStmts lt)++asStmts :: Test -> [Txt]+asStmts (Example e _ _) = NE.toList e+asStmts (Property t _ _) =+    ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"]++++-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result+myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))+myExecStmt stmt opts = do+    (temp, purge) <- liftIO newTempFile+    evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)")+    modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}+    result <- execStmt stmt opts >>= \case+              ExecComplete (Left err) _ -> pure $ Left $ show err+              ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp+              ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported"+    liftIO purge+    pure result++{- |GHC declarations required to execute test properties++Example:++prop> \(l::[Bool]) -> reverse (reverse l) == l++++ OK, passed 100 tests.++prop> \(l::[Bool]) -> reverse l == l+*** Failed! Falsified (after 6 tests and 2 shrinks):+[True,False]+-}+propSetup :: [Loc [Char]]+propSetup =+    locate0+        [ ":set -XScopedTypeVariables -XExplicitForAll"+        , "import qualified Test.QuickCheck as Q11"+        , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display+        ]
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE DuplicateRecordFields     #-}+{-# LANGUAGE ExtendedDefaultRules      #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ViewPatterns              #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -Wno-unused-imports #-}++{- |+A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.++For a full example see the "Ide.Plugin.Eval.Tutorial" module.+-}+module Ide.Plugin.Eval.CodeLens (+    codeLens,+    evalCommand,+) where++import           Control.Applicative                          (Alternative ((<|>)))+import           Control.Arrow                                (second, (>>>))+import           Control.Exception                            (bracket_, try)+import qualified Control.Exception                            as E+import           Control.Lens                                 (_1, _3, ix, (%~),+                                                               (<&>), (^.))+import           Control.Monad                                (guard, void,+                                                               when)+import           Control.Monad.IO.Class                       (MonadIO (liftIO))+import           Control.Monad.Trans.Except                   (ExceptT (..),+                                                               runExceptT)+import           Data.Aeson                                   (toJSON)+import           Data.Char                                    (isSpace)+import           Data.Foldable                                (toList)+import           Data.List                                    (dropWhileEnd,+                                                               find,+                                                               intercalate,+                                                               intersperse)+import qualified Data.Map                                     as Map+import           Data.Maybe                                   (catMaybes)+import           Data.String                                  (IsString)+import           Data.Text                                    (Text)+import qualified Data.Text                                    as T+import           Data.Typeable                                (Typeable)+import           Development.IDE.Core.Rules                   (IdeState,+                                                               runAction)+import           Development.IDE.Core.RuleTypes               (LinkableResult (linkableHomeMod),+                                                               NeedsCompilation (NeedsCompilation),+                                                               TypeCheck (..),+                                                               tmrTypechecked)+import           Development.IDE.Core.Shake                   (useNoFile_,+                                                               useWithStale_,+                                                               use_, uses_)+import           Development.IDE.GHC.Compat                   hiding (typeKind,+                                                               unitState)+import           Development.IDE.GHC.Compat.Util              (GhcException,+                                                               OverridingBool (..),+                                                               bagToList)+import           Development.IDE.GHC.Util                     (evalGhcEnv,+                                                               modifyDynFlags,+                                                               printOutputable)+import           Development.IDE.Import.DependencyInformation (transitiveDeps,+                                                               transitiveModuleDeps)+import           Development.IDE.Types.Location               (toNormalizedFilePath',+                                                               uriToFilePath')+import           GHC                                          (ClsInst,+                                                               ExecOptions (execLineNumber, execSourceFile),+                                                               FamInst,+                                                               GhcMonad,+                                                               NamedThing (getName),+                                                               defaultFixity,+                                                               execOptions,+                                                               exprType,+                                                               getInfo,+                                                               getInteractiveDynFlags,+                                                               isImport, isStmt,+                                                               parseName,+                                                               pprFamInst,+                                                               pprInstance,+                                                               typeKind)+++import           Development.IDE.Core.RuleTypes               (GetLinkable (GetLinkable),+                                                               GetModSummary (GetModSummary),+                                                               GetModuleGraph (GetModuleGraph),+                                                               GhcSessionDeps (GhcSessionDeps),+                                                               ModSummaryResult (msrModSummary))+import           Development.IDE.Core.Shake                   (VFSModified (VFSUnmodified))+import qualified Development.IDE.GHC.Compat.Core              as Compat (InteractiveImport (IIModule))+import qualified Development.IDE.GHC.Compat.Core              as SrcLoc (HasSrcSpan (getLoc),+                                                                         unLoc)+import           Development.IDE.Types.HscEnvEq               (HscEnvEq (hscEnv))+import qualified GHC.LanguageExtensions.Type                  as LangExt (Extension (..))++import           Development.IDE.Core.FileStore               (setSomethingModified)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Types.Shake                  (toKey)+import           GHC.Types.SrcLoc                             (UnhelpfulSpanReason (UnhelpfulInteractive))+import           Ide.Plugin.Error                             (PluginError (PluginInternalError),+                                                               handleMaybe,+                                                               handleMaybeM)+import           Ide.Plugin.Eval.Code                         (Statement,+                                                               asStatements,+                                                               myExecStmt,+                                                               propSetup,+                                                               resultRange,+                                                               testCheck,+                                                               testRanges)+import           Ide.Plugin.Eval.Config                       (EvalConfig (..),+                                                               getEvalConfig)+import           Ide.Plugin.Eval.GHC                          (addImport,+                                                               addPackages,+                                                               hasPackage,+                                                               setSessionAndInteractiveDynFlags,+                                                               showDynFlags)+import           Ide.Plugin.Eval.Parse.Comments               (commentsToSections)+import           Ide.Plugin.Eval.Parse.Option                 (parseSetFlags)+import           Ide.Plugin.Eval.Rules                        (queueForEvaluation,+                                                               unqueueForEvaluation)+import           Ide.Plugin.Eval.Types+import           Ide.Plugin.Eval.Util                         (gStrictTry,+                                                               isLiterate,+                                                               logWith,+                                                               response', timed)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens                   as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server+import           Language.LSP.VFS                             (virtualFileText)++{- | Code Lens provider+ NOTE: Invoked every time the document is modified, not just when the document is saved.+-}+codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens+codeLens st plId CodeLensParams{_textDocument} =+    let dbg = logWith st+        perf = timed dbg+     in perf "codeLens" $+            do+                let TextDocumentIdentifier uri = _textDocument+                fp <- uriToFilePathE uri+                let nfp = toNormalizedFilePath' fp+                    isLHS = isLiterate fp+                dbg "fp" fp+                (comments, _) <-+                    runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp+                -- dbg "excluded comments" $ show $  DL.toList $+                --     foldMap (\(L a b) ->+                --         case b of+                --             AnnLineComment{}  -> mempty+                --             AnnBlockComment{} -> mempty+                --             _                 -> DL.singleton (a, b)+                --     )+                --     $ apiAnnComments' pm_annotations+                dbg "comments" $ show comments++                -- Extract tests from source code+                let Sections{..} = commentsToSections isLHS comments+                    tests = testsBySection nonSetupSections+                    cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just [])+                let lenses =+                        [ CodeLens testRange (Just cmd') Nothing+                        | (section, ident, test) <- tests+                        , let (testRange, resultRange) = testRanges test+                              args = EvalParams (setupSections ++ [section]) _textDocument ident+                              cmd' =+                                (cmd :: Command)+                                    { _arguments = Just [toJSON args]+                                    , _title =+                                        if trivial resultRange+                                            then "Evaluate..."+                                            else "Refresh..."+                                    }+                        ]++                perf "tests" $+                    dbg "Tests" $+                        unwords+                            [ show (length tests)+                            , "tests in"+                            , show (length nonSetupSections)+                            , "sections"+                            , show (length setupSections)+                            , "setups"+                            , show (length lenses)+                            , "lenses."+                            ]++                return $ InL lenses+  where+    trivial (Range p p') = p == p'++evalCommandName :: CommandId+evalCommandName = "evalCommand"++evalCommand :: PluginId -> PluginCommand IdeState+evalCommand plId = PluginCommand evalCommandName "evaluate" (runEvalCmd plId)++type EvalId = Int++runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams+runEvalCmd plId st mtoken EvalParams{..} =+    let dbg = logWith st+        perf = timed dbg+        cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit+        cmd = do+            let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections++            let TextDocumentIdentifier{_uri} = module_+            fp <- uriToFilePathE _uri+            let nfp = toNormalizedFilePath' fp+            mdlText <- moduleText _uri++            -- enable codegen for the module which we need to evaluate.+            final_hscEnv <- liftIO $ bracket_+              (do queueForEvaluation st nfp+                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")+              (do unqueueForEvaluation st nfp+                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")+              (initialiseSessionForEval (needsQuickCheck tests) st nfp)++            evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId++            -- Perform the evaluation of the command+            edits <-+                perf "edits" $+                    liftIO $+                        evalGhcEnv final_hscEnv $ do+                            runTests evalCfg (st, fp) tests++            let workspaceEditsMap = Map.fromList [(_uri, addFinalReturn mdlText edits)]+            let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing++            return workspaceEdits+     in perf "evalCmd" $ ExceptT $+            withIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater ->+                runExceptT $ response' cmd++-- | Create an HscEnv which is suitable for performing interactive evaluation.+-- All necessary home modules will have linkables and the current module will+-- also be loaded into the environment.+--+-- The interactive context and interactive dynamic flags are also set appropiately.+initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv+initialiseSessionForEval needs_quickcheck st nfp = do+  (ms, env1) <- runAction "runEvalCmd" st $ do++    ms <- msrModSummary <$> use_ GetModSummary nfp+    deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp++    linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp+    linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed)+    -- We unset the global rdr env in mi_globals when we generate interfaces+    -- See Note [Clearing mi_globals after generating an iface]+    -- However, the eval plugin (setContext specifically) requires the rdr_env+    -- for the current module - so get it from the Typechecked Module and add+    -- it back to the iface for the current module.+    rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp+    let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc+        addRdrEnv hmi+          | iface <- hm_iface hmi+          , ms_mod ms == mi_module iface+          = hmi { hm_iface = iface { mi_globals = Just $!+#if MIN_VERSION_ghc(9,8,0)+                    forceGlobalRdrEnv+#endif+                      rdr_env+                }}+          | otherwise = hmi++    return (ms, linkable_hsc)+  -- Bit awkward we need to use evalGhcEnv here but setContext requires to run+  -- in the Ghc monad+  env2 <- liftIO $ evalGhcEnv env1 $ do+            setContext [Compat.IIModule (moduleName (ms_mod ms))]+            let df = flip xopt_set    LangExt.ExtendedDefaultRules+                   . flip xopt_unset  LangExt.MonomorphismRestriction+                   . flip gopt_set    Opt_ImplicitImportQualified+                   . flip gopt_unset  Opt_DiagnosticsShowCaret+                   $ (ms_hspp_opts ms) {+                        useColor = Never+                      , canUseColor = False }+            modifyDynFlags (const df)+            when needs_quickcheck $ void $ addPackages ["QuickCheck"]+            getSession+  return env2++addFinalReturn :: Text -> [TextEdit] -> [TextEdit]+addFinalReturn mdlText edits+    | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' =+        finalReturn mdlText : edits+    | otherwise = edits++finalReturn :: Text -> TextEdit+finalReturn txt =+    let ls = T.lines txt+        l = fromIntegral $ length ls -1+        c = fromIntegral $ T.length . last $ ls+        p = Position l c+     in TextEdit (Range p p) "\n"++moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text+moduleText uri =+    handleMaybeM (PluginInternalError "mdlText") $+      (virtualFileText <$>)+          <$> getVirtualFile+              (toNormalizedUri uri)++testsBySection :: [Section] -> [(Section, EvalId, Test)]+testsBySection sections =+    [(section, ident, test)+    | (ident, section) <- zip [0..] sections+    , test <- sectionTests section+    ]++type TEnv = (IdeState, String)+-- |GHC declarations required for expression evaluation+evalSetup :: Ghc ()+evalSetup = do+    preludeAsP <- parseImportDecl "import qualified Prelude as P"+    context <- getContext+    setContext (IIDecl preludeAsP : context)++runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]+runTests EvalConfig{..} e@(_st, _) tests = do+    df <- getInteractiveDynFlags+    evalSetup+    when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup++    mapM (processTest e df) tests+  where+    processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit+    processTest e@(st, fp) df (section, test) = do+        let dbg = logWith st+        let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section)+        rs <- runTest e df test+        dbg "TEST RESULTS" rs++        let checkedResult = testCheck eval_cfg_diff (section, test) rs+        let resultLines = concatMap T.lines checkedResult++        let edit = asEdit (sectionFormat section) test (map pad resultLines)+        dbg "TEST EDIT" edit+        return edit++    -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text]+    runTest _ df test+        | not (hasQuickCheck df) && isProperty test =+            return $+                singleLine+                    "Add QuickCheck to your cabal dependencies to run this test."+    runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test)++asEdit :: Format -> Test -> [Text] -> TextEdit+asEdit (MultiLine commRange) test resultLines+    -- A test in a block comment, ending with @-\}@ without newline in-between.+    | testRange test ^. L.end . L.line == commRange ^. L.end . L.line+    =+    TextEdit+        (Range+            (testRange test ^. L.end)+            (resultRange test ^. L.end)+        )+        ("\n" <> T.unlines (resultLines <> ["-}"]))+asEdit _ test resultLines =+    TextEdit (resultRange test) (T.unlines resultLines)++{- |+The result of evaluating a test line can be:+* a value+* nothing+* a (possibly multiline) error message++A value is returned for a correct expression.++Either a pure value:+>>> 'h' :"askell"+"haskell"++Or an 'IO a' (output on stdout/stderr is ignored):+>>> print "OK" >> return "ABC"+"ABC"++Nothing is returned for a correct directive:++>>>:set -XFlexibleInstances+>>> import Data.Maybe++Nothing is returned for a correct declaration (let..,x=, data, class)++>>> let x = 11+>>> y = 22+>>> data B = T | F+>>> class C a++Nothing is returned for an empty line:++>>>++A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code:++>>>:set -XNonExistent+Some flags have not been recognized: -XNonExistent++>>> cls C+Variable not in scope: cls :: t0 -> t+Data constructor not in scope: C++>>> "A+lexical error in string/character literal at end of input++Exceptions are shown as if printed, but it can be configured to include prefix like+in GHCi or doctest. This allows it to be used as a hack to simulate print until we+get proper IO support. See #1977++>>> 3 `div` 0+divide by zero++>>> error "Something went wrong\nbad times" :: E.SomeException+Something went wrong+bad times++Or for a value that does not have a Show instance and can therefore not be displayed:+>>> data V = V+>>> V+No instance for (Show V) arising from a use of ‘evalPrint’+-}+evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]+evals mark_exception (st, fp) df stmts = do+    er <- gStrictTry $ mapM eval stmts+    return $ case er of+        Left err -> errorLines err+        Right rs -> concat . catMaybes $ rs+  where+    dbg = logWith st+    eval :: Statement -> Ghc (Maybe [Text])+    eval (Located l stmt)+        | -- GHCi flags+          Just (words -> flags) <- parseSetFlags stmt = do+            dbg "{:SET" flags+            ndf <- getInteractiveDynFlags+            dbg "pre set" $ showDynFlags ndf+            eans <-+                liftIO $ try @GhcException $+                parseDynamicFlagsCmdLine ndf+                (map (L $ UnhelpfulSpan unhelpfulReason) flags)+            dbg "parsed flags" $ eans+              <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings)+            case eans of+                Left err -> pure $ Just $ errorLines $ show err+                Right (df', ignoreds, warns) -> do+                    let warnings = do+                            guard $ not $ null warns+                            pure $ errorLines $+                                prettyWarnings warns+                        igns = do+                            guard $ not $ null ignoreds+                            pure+                                ["Some flags have not been recognized: "+                                <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds)+                                ]+                    dbg "post set" $ showDynFlags df'+                    setSessionAndInteractiveDynFlags df'+                    pure $ warnings <> igns+        | -- A type/kind command+          Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt =+            evalGhciLikeCmd cmd arg+        | -- A statement+          isStmt pf stmt =+            do+                dbg "{STMT " stmt+                res <- exec stmt l+                let r = case res of+                        Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err+                        Right x  -> singleLine <$> x+                dbg "STMT} -> " r+                return r+        | -- An import+          isImport pf stmt =+            do+                dbg "{IMPORT " stmt+                _ <- addImport stmt+                return Nothing+        | -- A declaration+          otherwise =+            do+                dbg "{DECL " stmt+                void $ runDecls stmt+                return Nothing+    pf = initParserOpts df+    unhelpfulReason = UnhelpfulInteractive+    exec stmt l =+        let opts = execOptions{execSourceFile = fp, execLineNumber = l}+         in myExecStmt stmt opts++#if MIN_VERSION_ghc(9,8,0)+prettyWarnings :: Messages DriverMessage -> String+prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage)+#else+prettyWarnings :: [Warn] -> String+prettyWarnings = unlines . map prettyWarn++prettyWarn :: Warn -> String+prettyWarn Warn{..} =+    T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n"+    <> "    " <> SrcLoc.unLoc warnMsg+#endif++needsQuickCheck :: [(Section, Test)] -> Bool+needsQuickCheck = any (isProperty . snd)++hasQuickCheck :: DynFlags -> Bool+hasQuickCheck df = hasPackage df "QuickCheck"++singleLine :: String -> [Text]+singleLine s = [T.pack s]++{- |+ Convert error messages to a list of text lines+ Remove unnecessary information.+-}+errorLines :: String -> [Text]+errorLines =+        dropWhileEnd T.null+        . takeWhile (not . ("CallStack" `T.isPrefixOf`))+        . T.lines+        . T.pack++{- |+ Convert exception messages to a list of text lines+ Remove unnecessary information and mark it as exception.+ We use '*** Exception:' to make it identical to doctest+ output, see #2353.+-}+exceptionLines :: String -> [Text]+exceptionLines = (ix 0 %~ ("*** Exception: " <>)) . errorLines++{- |+>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])+["--2+2","--<BLANKLINE>"]+-}+pad_ :: Text -> Text -> Text+pad_ prefix = (prefix `T.append`) . convertBlank++convertBlank :: Text -> Text+convertBlank x+    | T.null x = "<BLANKLINE>"+    | otherwise = x++padPrefix :: IsString p => Format -> p+padPrefix SingleLine = "-- "+padPrefix _          = ""++{- | Resulting @Text@ MUST NOT prefix each line with @--@+   Such comment-related post-process will be taken place+   solely in 'evalGhciLikeCmd'.+-}+type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)++-- Should we use some sort of trie here?+ghciLikeCommands :: [(Text, GHCiLikeCmd)]+ghciLikeCommands =+    [ ("info", doInfoCmd False)+    , ("info!", doInfoCmd True)+    , ("kind", doKindCmd False)+    , ("kind!", doKindCmd True)+    , ("type", doTypeCmd)+    ]++evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text])+evalGhciLikeCmd cmd arg = do+    df <- getSessionDynFlags+    case lookup cmd ghciLikeCommands+        <|> snd+        <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of+        Just hndler ->+            fmap+                T.lines+                <$> hndler df arg+        _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg++doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)+doInfoCmd allInfo dflags s = do+    sdocs <- mapM infoThing (T.words s)+    pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs)+    where+        infoThing :: GHC.GhcMonad m => Text -> m SDoc+        infoThing (T.unpack -> str) = do+            names     <- GHC.parseName str+            mb_stuffs <- mapM (GHC.getInfo allInfo) names+            let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+                                            (catMaybes $ toList mb_stuffs)+            return $ vcat (intersperse (text "") $ map pprInfo filtered)++        filterOutChildren :: (a -> TyThing) -> [a] -> [a]+        filterOutChildren get_thing xs+            = filter (not . has_parent) xs+            where+                all_names = mkNameSet (map (getName . get_thing) xs)+                has_parent x = case tyThingParent_maybe (get_thing x) of+                                Just p  -> getName p `elemNameSet` all_names+                                Nothing -> False++        pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+        pprInfo (thing, fixity, cls_insts, fam_insts, docs)+            =  docs+            $$ pprTyThingInContextLoc thing+            $$ showFixity thing fixity+            $$ vcat (map GHC.pprInstance cls_insts)+            $$ vcat (map GHC.pprFamInst  fam_insts)++        pprTyThingInContextLoc :: TyThing -> SDoc+        pprTyThingInContextLoc tyThing+            = showWithLoc (pprDefinedAt (getName tyThing))+                          (pprTyThingInContext showToHeader tyThing)++        showWithLoc :: SDoc -> SDoc -> SDoc+        showWithLoc loc doc+            = hang doc 2 (text "\t--" <+> loc)++        showFixity :: TyThing -> Fixity -> SDoc+        showFixity thing fixity+            | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing)+                = ppr fixity <+> pprInfixName (GHC.getName thing)+            | otherwise = empty++doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)+doKindCmd False df arg = do+    let input = T.strip arg+    (_, kind) <- typeKind False $ T.unpack input+    let kindText = text (T.unpack input) <+> "::" <+> pprSigmaType kind+    pure $ Just $ T.pack (showSDoc df kindText)+doKindCmd True df arg = do+    let input = T.strip arg+    (ty, kind) <- typeKind True $ T.unpack input+    let kindDoc = text (T.unpack input) <+> "::" <+> pprSigmaType kind+        tyDoc = "=" <+> pprSigmaType ty+    pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)++doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)+doTypeCmd dflags arg = do+    let (emod, expr) = parseExprMode arg+    ty <- GHC.exprType emod $ T.unpack expr+    let rawType = T.strip $ T.pack $ showSDoc dflags $ pprSigmaType ty+        broken = T.any (\c -> c == '\r' || c == '\n') rawType+    pure $+        Just $+            if broken+                then+                    T.pack $+                        showSDoc dflags $+                            text (T.unpack expr)+                                $$ nest 2 ("::" <+> pprSigmaType ty)+                else expr <> " :: " <> rawType <> "\n"++parseExprMode :: Text -> (TcRnExprMode, T.Text)+parseExprMode rawArg = case T.break isSpace rawArg of+    ("+d", rest) -> (TM_Default, T.strip rest)+    _            -> (TM_Inst, rawArg)++data GhciLikeCmdException = GhciLikeCmdNotImplemented+    { ghciCmdName :: Text+    , ghciCmdArg  :: Text+    }+    deriving (Typeable)++instance Show GhciLikeCmdException where+    showsPrec _ GhciLikeCmdNotImplemented{..} =+        showString "unknown command '"+            . showString (T.unpack ghciCmdName)+            . showChar '\''++instance E.Exception GhciLikeCmdException++{-+>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1")+Just ("kind!","N + M + 1")+>>> parseGhciLikeCmd (T.pack ":kind a")+Just ("kind","a")+-}+parseGhciLikeCmd :: Text -> Maybe (Text, Text)+parseGhciLikeCmd input = do+    (':', rest) <- T.uncons $ T.stripStart input+    pure $ second T.strip $ T.break isSpace rest
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.Eval.Config+  ( properties+  , getEvalConfig+  , EvalConfig(..)+  ) where++import           Development.IDE+import           Ide.Plugin.Properties+import           Ide.Types             (PluginId)++-- | The Eval plugin configuration. (see 'properties')+data EvalConfig = EvalConfig+  { eval_cfg_diff      :: Bool+  , eval_cfg_exception :: Bool+  }+  deriving (Eq, Ord, Show)++properties :: Properties+    '[ 'PropertyKey "exception" 'TBoolean+     , 'PropertyKey "diff" 'TBoolean+     ]+properties = emptyProperties+  & defineBooleanProperty #diff+    "Enable the diff output (WAS/NOW) of eval lenses" True+  & defineBooleanProperty #exception+    "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi." False++getEvalConfig :: PluginId -> Action EvalConfig+getEvalConfig plId =+    EvalConfig+    <$> usePropertyAction #diff plId properties+    <*> usePropertyAction #exception plId properties
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP        #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-}++-- |GHC API utilities+module Ide.Plugin.Eval.GHC (+    addExtension,+    addImport,+    hasPackage,+    addPackages,+    modifyFlags,+    showDynFlags,+    setSessionAndInteractiveDynFlags,+) where++import           Data.List                       (isPrefixOf)+import           Data.Maybe                      (mapMaybe)+import           Data.String                     (fromString)+import qualified Data.Text                       as T+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import qualified Development.IDE.GHC.Compat.Util as EnumSet+import           Development.IDE.GHC.Util        (printOutputable)++import           GHC.LanguageExtensions.Type     (Extension (..))+import           Ide.Plugin.Eval.Util            (gStrictTry)++#if MIN_VERSION_ghc(9,3,0)+import           GHC                             (setTopSessionDynFlags,+                                                  setUnitDynFlags)+import           GHC.Driver.Env+import           GHC.Driver.Session              (getDynFlags)+#endif++{- $setup+>>> import GHC+>>> import GHC.Paths+>>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act)+>>> libdir+"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4"+-}++{- | True if specified package is present in DynFlags++-- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg)+>>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg))++>>> hasPackageTst "base"+Right True++>>> hasPackageTst "ghc"+Right True++>>> hasPackageTst "extra"+Left "<command line>: cannot satisfy -package extra\n    (use -v for more information)"++>>> hasPackageTst "QuickCheck"+Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"+-}+hasPackage :: DynFlags -> String -> Bool+hasPackage df = hasPackage_ (packageFlags df)++hasPackage_ :: [PackageFlag] -> [Char] -> Bool+hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags)++{- |+>>> run (return . pkgNames)+[]+-}+pkgNames :: DynFlags -> [String]+pkgNames = pkgNames_ . packageFlags++pkgNames_ :: [PackageFlag] -> [String]+pkgNames_ =+    mapMaybe+        ( \case+            ExposePackage _ (PackageArg n) _  -> Just n+            ExposePackage _ (UnitIdArg uid) _ -> Just $ T.unpack $ printOutputable uid+            _                                 -> Nothing+        )++{- | Expose a list of packages.+>>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs)++>>> addPackagesTest []+Right []++>>> addPackagesTest ["base","base","array"]+Right [-package base{package base True ([])},-package array{package array True ([])}]++>>> addPackagesTest ["Cabal"]+Right [-package Cabal{package Cabal True ([])}]++>>> addPackagesTest ["QuickCheck"]+Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"++>>> addPackagesTest ["base","notThere"]+Left "<command line>: cannot satisfy -package notThere\n    (use -v for more information)"++prop> \(x::Int) -> x + x == 2 * x++++ OK, passed 100 tests.+-}+addPackages :: [String] -> Ghc (Either String DynFlags)+addPackages pkgNames = gStrictTry $+    modifyFlags $ \df ->+        df{packageFlags = foldr (\pkgName pf -> if hasPackage_ pf pkgName then pf else expose pkgName : pf) (packageFlags df) pkgNames}+  where+    expose name = ExposePackage ("-package " ++ name) (PackageArg name) (ModRenaming True [])++modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags+modifyFlags f = do+    df <- getSessionDynFlags+    _ <- setSessionDynFlags (f df)+    getSessionDynFlags++-- modifyFlags f = do+--         modifyDynFlags f+--         getSessionDynFlags++{- | Add import to evaluation context++>>> run $ \_ -> addImport "import Data.Maybe"+Could not find module ‘Data.Maybe’+Use -v (or `:set -v` in ghci) to see a list of the files searched for.++>>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe"+[import Data.Maybe]++>>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M"+[import qualified Data.Maybe as M]+-}+addImport :: GhcMonad m => String -> m [InteractiveImport]+addImport i = do+    ctx <- getContext+    -- dbgO "CONTEXT" ctx+    idecl <- parseImportDecl i+    setContext $ IIDecl idecl : ctx+    -- ctx' <- getContext+    -- dbg "CONTEXT'" ctx'+    getContext++{- | Add extension to interactive evaluation session+>>> import GHC.LanguageExtensions.Type(Extension(..))+>>> run $ \_ -> addExtension DeriveGeneric+()+-}+addExtension :: GhcMonad m => Extension -> m ()+addExtension ext =+    modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext}++setExtension :: InteractiveContext -> Extension -> InteractiveContext+setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext}++deriving instance Read Extension++-- Partial display of DynFlags contents, for testing purposes+showDynFlags :: DynFlags -> String+showDynFlags df =+    T.unpack . printOutputable . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $+        [ ("extensions", ppr . extensions $ df)+        , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df)+        , ("importPaths", vList $ importPaths df)+        , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df)+        , -- , ("includePaths", text . show $ includePaths df)+          -- ("packageEnv", ppr $ packageEnv df)+          ("pkgNames", vcat . map text $ pkgNames df)+        , ("packageFlags", vcat . map ppr $ packageFlags df)+        -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df)+        -- ("pkgDatabase", text . show <$> pkgDatabase $ df)+        ]++vList :: [String] -> SDoc+vList = vcat . map text++setSessionAndInteractiveDynFlags :: DynFlags -> Ghc ()+setSessionAndInteractiveDynFlags df = do+#if MIN_VERSION_ghc(9,3,0)+    _ <- setUnitDynFlags (homeUnitId_ df) df+    modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ df))+    df' <- getDynFlags+    setTopSessionDynFlags df'+#else+    _ <- setSessionDynFlags df+#endif+    sessDyns <- getSessionDynFlags+    setInteractiveDynFlags sessDyns
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -0,0 +1,565 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE TemplateHaskell    #-}++module Ide.Plugin.Eval.Parse.Comments where++import qualified Control.Applicative.Combinators.NonEmpty as NE+import           Control.Arrow                            (first, (&&&), (>>>))+import           Control.Lens                             (lensField, lensRules,+                                                           view, (.~), (^.))+import           Control.Lens.Extras                      (is)+import           Control.Lens.TH                          (makeLensesWith,+                                                           makePrisms,+                                                           mappingNamer)+import           Control.Monad                            (guard, void, when)+import           Control.Monad.Combinators                ()+import           Control.Monad.Reader                     (ask)+import           Control.Monad.Trans.Reader               (Reader, runReader)+import qualified Data.Char                                as C+import qualified Data.DList                               as DL+import qualified Data.Foldable                            as F+import           Data.Function                            ((&))+import           Data.Functor                             ((<&>))+import           Data.Functor.Identity+import           Data.List.NonEmpty                       (NonEmpty ((:|)))+import qualified Data.List.NonEmpty                       as NE+import           Data.Map.Strict                          (Map)+import qualified Data.Map.Strict                          as Map+import qualified Data.Text                                as T+import           Data.Void                                (Void)+import           GHC.Generics                             hiding (UInt, to)+import           Ide.Plugin.Eval.Types+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Types++import qualified Text.Megaparsec                          as P+import           Text.Megaparsec+import           Text.Megaparsec.Char                     (alphaNumChar, char,+                                                           eol, hspace,+                                                           letterChar)++{-+We build parsers combining the following three kinds of them:++    *   Line parser - paring a single line into an input,+        works both for line- and block-comments.+        A line should be a proper content of lines contained in comment:+        doesn't include starting @--@ and @{\-@ and no ending @-\}@++    *   Line comment group parser: parses a contiguous group of+        tuples of position and line comment into sections of line comments.+        Each input MUST start with @--@.++    *   Block comment parser: Parsing entire block comment into sections.+        Input must be surrounded by @{\-@ and @-\}@.+-}++-- | Line parser+type LineParser a = forall m. Monad m => ParsecT Void String m a++-- | Line comment group parser+type LineGroupParser = Parsec Void [(Range, RawLineComment)]++data BlockEnv = BlockEnv+    { isLhs      :: Bool+    , blockRange :: Range+    }+    deriving (Show, Eq, Ord)++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''BlockEnv++-- | Block comment parser+type BlockCommentParser = ParsecT Void String (Reader BlockEnv)++-- | Prop line, with "prop>" stripped off+newtype PropLine = PropLine {getPropLine :: String}+    deriving (Show)++-- | Example line, with @>>>@ stripped off+newtype ExampleLine = ExampleLine {getExampleLine :: String}+    deriving (Show)++data TestComment+    = AProp+        { testCommentRange :: Range+        , lineProp         :: PropLine+        , propResults      :: [String]+        }+    | AnExample+        { testCommentRange :: Range+        , lineExamples     :: NonEmpty ExampleLine+        , exampleResults   :: [String]+        }+    deriving (Show)++-- | Classification of comments+data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String+    deriving (Read, Show, Eq, Ord)++-- | Single line or block comments?+data CommentStyle = Line | Block Range+    deriving (Show, Eq, Ord, Generic)++makePrisms ''CommentStyle++commentsToSections ::+    -- | True if it is literate Haskell+    Bool ->+    Comments ->+    Sections+commentsToSections isLHS Comments {..} =+    let (lineSectionSeeds, lineSetupSeeds) =+            foldMap+                ( \lcs ->+                    let theRan =+                            Range+                                (view L.start $ fst $ NE.head lcs)+                                (view L.end $ fst $ NE.last lcs)+                     in case parseMaybe lineGroupP $ NE.toList lcs of+                            Nothing -> mempty+                            Just (mls, rs) ->+                                ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls)+                                , -- orders setup sections in ascending order+                                  if null rs+                                    then mempty+                                    else+                                        Map.singleton theRan $+                                            DL.singleton (Line, rs)+                                )+                )+                $ groupLineComments $+                    Map.filterWithKey+                        -- FIXME:+                        -- To comply with the initial behaviour of+                        -- Extended Eval Plugin;+                        -- but it also rejects modules with+                        -- non-zero base indentation level!+                        ( \pos _ ->+                            if isLHS+                                then pos ^. L.start . L.character == 2+                                else pos ^. L.start . L.character == 0+                        )+                        lineComments+        (blockSeed, blockSetupSeeds) =+            foldMap+                ( \(ran, lcs) ->+                    case parseBlockMaybe isLHS ran blockCommentBP $+                        getRawBlockComment lcs of+                        Nothing -> mempty+                        Just (Named "setup", grp) ->+                            -- orders setup sections in ascending order+                            ( mempty+                            , Map.singleton ran $+                                DL.singleton (Block ran, grp)+                            )+                        Just grp ->+                            ( Map.singleton ran grp+                            , mempty+                            )+                )+                -- It seems Extended Eval Plugin doesn't constraint+                -- starting indentation level for block comments.+                -- Rather, it constrains the indentation level /inside/+                -- block comment body.+                $ Map.toList blockComments+        lineSections =+            lineSectionSeeds <&> uncurry (testsToSection Line)+        multilineSections =+            Map.mapWithKey+                (uncurry . testsToSection . Block)+                blockSeed+        setupSections =+            -- Setups doesn't need Dummy position+            map+                ( \(style, tests) ->+                    testsToSection+                        style+                        (Named "setup")+                        tests+                )+                $ DL.toList $+                    F.fold $+                        Map.unionWith (<>) lineSetupSeeds blockSetupSeeds+        nonSetupSections = F.toList $ lineSections `Map.union` multilineSections+     in Sections {..}++parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a+parseBlockMaybe isLhs blockRange p i =+    case runReader (runParserT p' "" i) BlockEnv {..} of+        Left {} -> Nothing+        Right a -> Just a+    where+        p' = do+            updateParserState $ \st ->+                st+                    { statePosState =+                        (statePosState st)+                            { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start+                            }+                    }+            p++type CommentRange = Range++type SectionRange = Range++testsToSection ::+    CommentStyle ->+    CommentFlavour ->+    [TestComment] ->+    Section+testsToSection style flav tests =+    let sectionName+            | Named name <- flav = name+            | otherwise = ""+        sectionLanguage = case flav of+            HaddockNext -> Haddock+            HaddockPrev -> Haddock+            _           -> Plain+        sectionTests = map fromTestComment tests+        sectionFormat =+            case style of+                Line      -> SingleLine+                Block ran -> MultiLine ran+     in Section {..}++fromTestComment :: TestComment -> Test+fromTestComment AProp {..} =+    Property+        { testline = getPropLine lineProp+        , testOutput = propResults+        , testRange = testCommentRange+        }+fromTestComment AnExample {..} =+    Example+        { testLines = getExampleLine <$> lineExamples+        , testOutput = exampleResults+        , testRange = testCommentRange+        }++-- * Block comment parser++{- $setup+>>> dummyPos = Position 0 0+>>> parseE p = either (error . errorBundlePretty) id . parse p ""+-}++-- >>> parseE (blockCommentBP True dummyPos) "{- |\n  >>> 5+5\n  11\n  -}"+-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = ["  11"]}])++blockCommentBP ::+    -- | True if Literate Haskell+    BlockCommentParser (CommentFlavour, [TestComment])+blockCommentBP = do+    skipCount 2 anySingle -- "{-"+    void $ optional $ char ' '+    flav <- commentFlavourP+    hit <- skipNormalCommentBlock+    if hit+        then do+            body <-+                many $+                    (blockExamples <|> blockProp)+                        <* skipNormalCommentBlock+            void takeRest -- just consume the rest+            pure (flav, body)+        else pure (flav, [])++skipNormalCommentBlock :: BlockCommentParser Bool+skipNormalCommentBlock = do+    BlockEnv {..} <- ask+    skipManyTill (normalLineP isLhs $ Block blockRange) $+        False <$ try (optional (chunk "-}") *> eof)+            <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange)++testSymbol :: Bool -> CommentStyle -> LineParser ()+testSymbol isLHS style =+    -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+    -- it must skip one space after a comment!+    -- This prevents Eval Plugin from working on+    -- modules with non-standard base indentation-level.+    when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+        *> (exampleSymbol <|> propSymbol)++eob :: LineParser ()+eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol++blockExamples+    , blockProp ::+        BlockCommentParser TestComment+blockExamples = do+    BlockEnv {..} <- ask+    (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange+    AnExample ran examples <$> resultBlockP+blockProp = do+    BlockEnv {..} <- ask+    (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange+    AProp ran prop <$> resultBlockP++withRange ::+    (TraversableStream s, Ord v, Traversable t) =>+    ParsecT v s m (t (a, Position)) ->+    ParsecT v s m (Range, t a)+withRange p = do+    beg <- sourcePosToPosition <$> getSourcePos+    as <- p+    let fin+            | null as = beg+            | otherwise = snd $ last $ F.toList as+    pure (Range beg fin, fst <$> as)++resultBlockP :: BlockCommentParser [String]+resultBlockP = do+    BlockEnv {..} <- ask+    many $+        fmap fst $ nonEmptyNormalLineP isLhs $+            Block blockRange++positionToSourcePos :: Position -> SourcePos+positionToSourcePos pos =+    P.SourcePos+        { sourceName = "<block comment>"+        , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. L.line+        , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. L.character+        }++sourcePosToPosition :: SourcePos -> Position+sourcePosToPosition SourcePos {..} =+    Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1)++-- * Line Group Parser++{- |+Result: a tuple of ordinary line tests and setting sections.++TODO: Haddock comment can adjacent to vanilla comment:++    @+        -- Vanilla comment+        -- Another vanilla+        -- | This parses as Haddock comment as GHC+    @++This behaviour is not yet handled correctly in Eval Plugin;+but for future extension for this, we use a tuple here instead of 'Either'.+-}+lineGroupP ::+    LineGroupParser+        (Maybe (CommentFlavour, [TestComment]), [TestComment])+lineGroupP = do+    (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest)+    case flav of+        Named "setup" -> (Nothing,) <$> lineCommentSectionsP+        flav          -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP++-- >>>  parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"]+-- Variable not in scope: dummyPosition :: Position++commentFlavourP :: LineParser CommentFlavour+commentFlavourP =+    P.option+        Vanilla+        ( HaddockNext <$ char '|'+            <|> HaddockPrev <$ char '^'+            <|> Named <$ char '$'+                <* optional hspace+                <*> ((:) <$> letterChar <*> P.many alphaNumChar)+        )+        <* optional (char ' ')++lineCommentHeadP :: LineParser ()+lineCommentHeadP = do+    -- and no operator symbol character follows.+    void $ chunk "--"+    skipMany $ char '-'+    void $ optional $ char ' '++lineCommentSectionsP ::+    LineGroupParser [TestComment]+lineCommentSectionsP = do+    skipMany normalLineCommentP+    many $+        exampleLinesGP+            <|> uncurry AProp <$> propLineGP <*> resultLinesP+                <* skipMany normalLineCommentP++lexemeLine :: LineGroupParser a -> LineGroupParser a+lexemeLine p = p <* skipMany normalLineCommentP++resultLinesP :: LineGroupParser [String]+resultLinesP = many nonEmptyLGP++normalLineCommentP :: LineGroupParser (Range, String)+normalLineCommentP =+    parseLine (fst <$ commentFlavourP <*> normalLineP False Line)++nonEmptyLGP :: LineGroupParser String+nonEmptyLGP =+    try $+        fmap snd $+            parseLine $+                fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line++exampleLinesGP :: LineGroupParser TestComment+exampleLinesGP =+    lexemeLine $+        uncurry AnExample . first convexHullRange . NE.unzip+            <$> NE.some exampleLineGP+            <*> resultLinesP++convexHullRange :: NonEmpty Range -> Range+convexHullRange nes =+    Range (NE.head nes ^. L.start) (NE.last nes ^. L.end)++exampleLineGP :: LineGroupParser (Range, ExampleLine)+exampleLineGP =+    -- In line-comments, indentation-level inside comment doesn't matter.+    parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line)++propLineGP :: LineGroupParser (Range, PropLine)+propLineGP =+    -- In line-comments, indentation-level inside comment doesn't matter.+    parseLine (fst <$ commentFlavourP <*> propLineStrP False Line)++{- |+Turning a line parser into line group parser consuming a single line comment.+Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space.+fails if the input does not start with "--".++__N.B.__ We don't strip comment flavours.++>>> pck = (:[]).(:[]) . RawLineComment++>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A"+Just [">>> A"]++>>> parseMaybe (parseLine $ takeRest) $ pck "---  >>> A"+Just [" >>> A"]++>>> parseMaybe (parseLine takeRest) $ pck ""+Nothing+-}+parseLine ::+    (Ord (f RawLineComment), Traversable f) =>+    LineParser a ->+    Parsec Void [f RawLineComment] (f a)+parseLine p =+    P.token+        (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment)+        mempty++-- * Line Parsers++-- | Non-empty normal line.+nonEmptyNormalLineP ::+    -- | True if Literate Haskell+    Bool ->+    CommentStyle ->+    LineParser (String, Position)+nonEmptyNormalLineP isLHS style = try $ do+    (ln, pos) <- normalLineP isLHS style+    guard $+        case style of+            Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""]+            _       -> not $ all C.isSpace ln+    pure (ln, pos)++{- | Normal line is a line neither a example nor prop.+ Empty line is normal.+-}+normalLineP ::+    -- | True if Literate Haskell+    Bool ->+    CommentStyle ->+    LineParser (String, Position)+normalLineP isLHS style = do+    notFollowedBy+        (try $ testSymbol isLHS style)+    when (isLHS && is _Block style) $+        void $ count' 0 2 $ char ' '+    consume style++consume :: CommentStyle -> LineParser (String, Position)+consume style =+    case style of+        Line     -> (,) <$> takeRest <*> getPosition+        Block {} -> manyTill_ anySingle (getPosition <* eob)++getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position+getPosition = sourcePosToPosition <$> getSourcePos++-- | Parses example test line.+exampleLineStrP ::+    -- | True if Literate Haskell+    Bool ->+    CommentStyle ->+    LineParser (ExampleLine, Position)+exampleLineStrP isLHS style =+    try $+        -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+        -- it must skip one space after a comment!+        -- This prevents Eval Plugin from working on+        -- modules with non-standard base indentation-level.+        when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+            *> exampleSymbol+            *> (first ExampleLine <$> consume style)++exampleSymbol :: LineParser ()+exampleSymbol =+    chunk ">>>" *> P.notFollowedBy (char '>')++propSymbol :: LineParser ()+propSymbol = chunk "prop>" *> P.notFollowedBy (char '>')++-- | Parses prop test line.+propLineStrP ::+    -- | True if Literate HAskell+    Bool ->+    CommentStyle ->+    LineParser (PropLine, Position)+propLineStrP isLHS style =+    -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+    -- it must skip one space after a comment!+    -- This prevents Eval Plugin from working on+    -- modules with non-standard base indentation-level.+    when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+        *> chunk "prop>"+        *> P.notFollowedBy (char '>')+        *> (first PropLine <$> consume style)++-- * Utilities++{- |+Given a sequence of tokens increasing in their starting position,+groups them into sublists consisting of contiguous tokens;+Two adjacent tokens are considered to be contiguous if++    * line number increases by 1, and+    * they have same starting column.++>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)]+[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]]+-}+contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]+contiguousGroupOn toLineCol = foldr step []+    where+        step a [] = [pure a]+        step a bss0@((b :| bs) : bss)+            | let (aLine, aCol) = toLineCol a+              , let (bLine, bCol) = toLineCol b+              , aLine + 1 == bLine && aCol == bCol =+                (a :| b : bs) : bss+            | otherwise = pure a : bss0++{- | Given a map from positions, divides them into subgroup+ with contiguous line and columns.+-}+groupLineComments ::+    Map Range a -> [NonEmpty (Range, a)]+groupLineComments =+    contiguousGroupOn (fst >>> view L.start >>> view L.line &&& view L.character)+        . Map.toList
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wwarn #-}++-- | GHC language options parser+module Ide.Plugin.Eval.Parse.Option (+    langOptions,+    parseSetFlags,+) where++import           Control.Arrow        (left)+import           Data.Void            (Void)+import           Text.Megaparsec+import           Text.Megaparsec.Char++{- |+>>> langOptions ":set   -XBinaryLiterals  -XOverloadedStrings "+Right ["BinaryLiterals","OverloadedStrings"]++>>> langOptions ":set"+Right []++>>> langOptions ""+Left "No match"+-}+langOptions :: String -> Either String [String]+langOptions =+  left errorBundlePretty+  . parse (space *> languageOpts <* eof) ""++parseSetFlags :: String -> Maybe String+parseSetFlags = parseMaybe+    (hspace *> chunk ":set"+        *> hspace1 *> takeRest+        :: Parsec Void String String+    )++-- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings"+-- Just ["BinaryLiterals","OverloadedStrings"]+languageOpts :: Parsec Void String [String]+languageOpts = string ":set" *> space1+  *> many (string "-X" *> many letterChar <* space)
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}++-- To avoid warning "Pattern match has inaccessible right hand side"+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where++import           Control.Monad.IO.Class               (MonadIO (liftIO))+import           Data.HashSet                         (HashSet)+import qualified Data.HashSet                         as Set+import           Data.IORef+import qualified Data.Map.Strict                      as Map+import           Data.String                          (fromString)+import           Development.IDE                      (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),+                                                       GetParsedModuleWithComments (GetParsedModuleWithComments),+                                                       IdeState,+                                                       NeedsCompilation (NeedsCompilation),+                                                       NormalizedFilePath,+                                                       RuleBody (RuleNoDiagnostics),+                                                       Rules, defineEarlyCutoff,+                                                       encodeLinkableType,+                                                       fromNormalizedFilePath,+                                                       msrModSummary,+                                                       realSrcSpanToRange,+                                                       useWithStale_,+                                                       use_)+import           Development.IDE.Core.PositionMapping (toCurrentRange)+import           Development.IDE.Core.Rules           (computeLinkableTypeForDynFlags,+                                                       needsCompilationRule)+import           Development.IDE.Core.Shake           (IsIdeGlobal,+                                                       RuleBody (RuleWithCustomNewnessCheck),+                                                       addIdeGlobal,+                                                       getIdeGlobalAction,+                                                       getIdeGlobalState)+import qualified Development.IDE.Core.Shake           as Shake+import           Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat           as SrcLoc+import qualified Development.IDE.GHC.Compat.Util      as FastString+import           Development.IDE.Graph                (alwaysRerun)+import           Ide.Logger         (Pretty (pretty),+                                                       Recorder, WithPriority,+                                                       cmapWithPrio)+import           GHC.Parser.Annotation+import           Ide.Plugin.Eval.Types++import qualified Data.ByteString                      as BS++newtype Log = LogShake Shake.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog++rules :: Recorder (WithPriority Log) -> Rules ()+rules recorder = do+    evalParsedModuleRule recorder+    redefinedNeedsCompilation recorder+    isEvaluatingRule recorder+    addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)++newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))+instance IsIdeGlobal EvaluatingVar++queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()+queueForEvaluation ide nfp = do+    EvaluatingVar var <- getIdeGlobalState ide+    atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ()))++unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()+unqueueForEvaluation ide nfp = do+    EvaluatingVar var <- getIdeGlobalState ide+    -- remove the module from the Evaluating state, so that next time it won't evaluate to True+    atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ())++#if MIN_VERSION_ghc(9,5,0)+getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment]+getAnnotations (L _ m@(HsModule { hsmodExt = XModulePs {hsmodAnn = anns'}})) =+#else+getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]+getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) =+#endif+    priorComments annComments <> getFollowingComments annComments+     <> concatMap getCommentsForDecl (hsmodImports m)+     <> concatMap getCommentsForDecl (hsmodDecls m)+       where+         annComments = epAnnComments anns'++getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e+                            -> [LEpaComment]+getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs+getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = []++apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]+apiAnnComments' pm = do+  L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm+  pure (L (anchor span) c)++pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan+pattern RealSrcSpanAlready x = x++evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()+evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do+    (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp+    let comments = foldMap (\case+                L (RealSrcSpanAlready real) bdy+                    | FastString.unpackFS (srcSpanFile real) ==+                        fromNormalizedFilePath nfp+                    , let ran0 = realSrcSpanToRange real+                    , Just curRan <- toCurrentRange posMap ran0+                    ->++                        -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',+                        -- we can concentrate on these two+                        case bdy of+                            EpaLineComment cmt ->+                                mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }+                            EpaBlockComment cmt ->+                                mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }+                            _ -> mempty+                _ -> mempty+            )+            $ apiAnnComments' pm+        -- we only care about whether the comments are null+        -- this is valid because the only dependent is NeedsCompilation+        fingerPrint = fromString $ if nullComments comments then "" else "1"+    return (Just fingerPrint, Just comments)++isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()+isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do+    alwaysRerun+    EvaluatingVar var <- getIdeGlobalAction+    b <- liftIO $ (f `Set.member`) <$> readIORef var+    return (Just (if b then BS.singleton 1 else BS.empty), Just b)++-- Redefine the NeedsCompilation rule to set the linkable type to Just _+-- whenever the module is being evaluated+-- This will ensure that the modules are loaded with linkables+-- and the interactive session won't try to compile them on the fly,+-- leading to much better performance of the evaluate code lens+redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()+redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do+    isEvaluating <- use_ IsEvaluating f++    if not isEvaluating then needsCompilationRule f else do+        ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f+        let df' = ms_hspp_opts ms+            linkableType = computeLinkableTypeForDynFlags df'+            fp = encodeLinkableType $ Just linkableType++        pure (Just fp, Just (Just linkableType))
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DerivingStrategies   #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wwarn #-}++module Ide.Plugin.Eval.Types+    ( locate,+      locate0,+      Test (..),+      isProperty,+      Format (..),+      Language (..),+      Section (..),+      Sections (..),+      hasTests,+      hasPropertyTest,+      splitSections,+      Loc,+      Located (..),+      Comments (..),+      RawBlockComment (..),+      RawLineComment (..),+      unLoc,+      Txt,+      EvalParams(..),+      GetEvalComments(..),+      IsEvaluating(..),+      nullComments)+where++import           Control.DeepSeq               (deepseq)+import           Data.Aeson                    (FromJSON, ToJSON)+import           Data.List                     (partition)+import           Data.List.NonEmpty            (NonEmpty)+import           Data.Map.Strict               (Map)+import           Data.String                   (IsString (..))+import           Development.IDE               (Range, RuleResult)+import           Development.IDE.Graph.Classes+import           GHC.Generics                  (Generic)+import           Language.LSP.Protocol.Types   (TextDocumentIdentifier)+import qualified Text.Megaparsec               as P++-- | A thing with a location attached.+data Located l a = Located {location :: l, located :: a}+    deriving (Eq, Show, Ord, Functor, Generic, FromJSON, ToJSON)++-- | Discard location information.+unLoc :: Located l a -> a+unLoc (Located _ a) = a++instance (NFData l, NFData a) => NFData (Located l a) where+    rnf (Located loc a) = loc `deepseq` a `deepseq` ()++type Loc = Located Line++type Line = Int++locate :: Loc [a] -> [Loc a]+locate (Located l tst) = zipWith Located [l ..] tst++locate0 :: [a] -> [Loc a]+locate0 = locate . Located 0++type Txt = String++data Sections = Sections+    { nonSetupSections :: [Section]+    , setupSections    :: [Section]+    }+    deriving (Show, Eq, Generic)++data Section = Section+    { sectionName     :: Txt+    , sectionTests    :: [Test]+    , sectionLanguage :: Language+    , sectionFormat   :: Format+    }+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++hasTests :: Section -> Bool+hasTests = not . null . sectionTests++hasPropertyTest :: Section -> Bool+hasPropertyTest = any isProperty . sectionTests++-- |Split setup and normal sections+splitSections :: [Section] -> ([Section], [Section])+splitSections = partition ((== "setup") . sectionName)++data Test+    = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range}+    | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range}+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++data IsEvaluating = IsEvaluating+    deriving (Eq, Show, Typeable, Generic)+instance Hashable IsEvaluating+instance NFData   IsEvaluating++type instance RuleResult IsEvaluating = Bool++data GetEvalComments = GetEvalComments+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetEvalComments+instance NFData   GetEvalComments++type instance RuleResult GetEvalComments = Comments+data Comments = Comments+    { lineComments  :: Map Range RawLineComment+    , blockComments :: Map Range RawBlockComment+    }+    deriving (Show, Eq, Ord, Generic)++nullComments :: Comments -> Bool+nullComments Comments{..} = null lineComments && null blockComments++instance NFData Comments++newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String}+    deriving (Show, Eq, Ord)+    deriving newtype+        ( IsString+        , P.Stream+        , P.TraversableStream+        , P.VisualStream+        , Semigroup+        , Monoid+        , NFData+        )++newtype RawLineComment = RawLineComment {getRawLineComment :: String}+    deriving (Show, Eq, Ord)+    deriving newtype+        ( IsString+        , P.Stream+        , P.TraversableStream+        , P.VisualStream+        , Semigroup+        , Monoid+        , NFData+        )++instance Semigroup Comments where+    Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs')++instance Monoid Comments where+    mempty = Comments mempty mempty++isProperty :: Test -> Bool+isProperty Property {} = True+isProperty _           = False++data Format+    = SingleLine+    | -- | @Range@ is that of surrounding entire block comment, not section.+      -- Used for detecting no-newline test commands.+      MultiLine Range+    deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData)++data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData)++data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++instance IsString ExpectedLine where+    fromString = ExpectedLine . return . LineChunk++data LineChunk = LineChunk String | WildCardChunk+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++instance IsString LineChunk where+    fromString = LineChunk++type EvalId = Int++-- | Specify the test section to execute+data EvalParams = EvalParams+    { sections :: [Section]+    , module_  :: !TextDocumentIdentifier+    , evalId   :: !EvalId -- ^ unique group id; for test uses+    }+    deriving (Eq, Show, Generic, FromJSON, ToJSON)
+ plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}++-- |Debug utilities+module Ide.Plugin.Eval.Util (+    timed,+    isLiterate,+    response',+    gStrictTry,+    logWith,+) where++import           Control.Exception                     (SomeException, evaluate,+                                                        fromException)+import           Control.Monad.Error.Class             (MonadError (throwError))+import           Control.Monad.IO.Class                (MonadIO (liftIO))+import           Control.Monad.Trans.Class             (MonadTrans (lift))+import           Control.Monad.Trans.Except            (ExceptT (..),+                                                        runExceptT)+import           Data.Aeson                            (Value)+import           Data.Bifunctor                        (second)+import           Data.String                           (IsString (fromString))+import qualified Data.Text                             as T+import           Development.IDE                       (IdeState, Priority (..),+                                                        ideLogger, logPriority)+import qualified Development.IDE.Core.PluginUtils      as PluginUtils+import           Development.IDE.GHC.Compat.Outputable+import           Development.IDE.GHC.Compat.Util       (MonadCatch, bagToList,+                                                        catch)+import           GHC.Exts                              (toList)+import           GHC.Stack                             (HasCallStack, callStack,+                                                        srcLocFile,+                                                        srcLocStartCol,+                                                        srcLocStartLine)+import           Ide.Plugin.Error+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server+import           System.FilePath                       (takeExtension)+import           System.Time.Extra                     (duration, showDuration)+import           UnliftIO.Exception                    (catchAny)++timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b+timed out name op = do+    (secs, r) <- duration op+    _ <- out name (showDuration secs)+    return r++-- | Log using hie logger, reports source position of logging statement+logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m ()+logWith state key val =+    liftIO . logPriority (ideLogger state) logLevel $+        T.unwords+            [T.pack logWithPos, asT key, asT val]+  where+    logWithPos =+        let stk = toList callStack+            pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos]+         in case stk of+              []    -> ""+              (x:_) -> pr $ snd x++    asT :: Show a => a -> T.Text+    asT = T.pack . show++-- | Set to Info to see extensive debug info in hie log, set to Debug in production+logLevel :: Priority+logLevel = Debug -- Info++isLiterate :: FilePath -> Bool+isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"]++response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null)+response' act = do+    res <-  ExceptT (runExceptT act+             `catchAny` \e -> do+                res <- showErr e+                pure . Left  . PluginInternalError $ fromString res)+    _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ())+    pure $ InR Null++gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b)+gStrictTry op =+    catch+        (op >>= fmap Right . gevaluate)+        (fmap Left . showErr)++gevaluate :: MonadIO m => a -> m a+gevaluate = liftIO . evaluate++showErr :: Monad m => SomeException -> m String+showErr e =+#if MIN_VERSION_ghc(9,3,0)+  case fromException e of+    -- On GHC 9.4+, the show instance adds the error message span+    -- We don't want this for the plugin+    -- So render without the span.+    Just (SourceError msgs) -> return $ renderWithContext defaultSDocContext+                                      $ vcat+                                      $ bagToList+                                      $ fmap (vcat . unDecorated+                                                   . diagnosticMessage+#if MIN_VERSION_ghc(9,5,0)+                                                    (defaultDiagnosticOpts @GhcMessage)+#endif+                                                   . errMsgDiagnostic)+                                      $ getMessages msgs+    _ ->+#endif+      return . show $ e
+ plugins/hls-eval-plugin/test/Main.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}+module Main+  ( main+  ) where++import           Control.Lens               (_Just, folded, preview, view, (^.),+                                             (^..))+import           Data.Aeson                 (Value (Object), fromJSON, object,+                                             (.=))+import           Data.Aeson.Types           (Pair, Result (Success))+import           Data.List                  (isInfixOf)+import           Data.List.Extra            (nubOrdOn)+import qualified Data.Map                   as Map+import           Data.Row+import qualified Data.Text                  as T+import           Ide.Plugin.Config          (Config)+import qualified Ide.Plugin.Config          as Plugin+import qualified Ide.Plugin.Eval            as Eval+import           Ide.Plugin.Eval.Types      (EvalParams (..), Section (..),+                                             testOutput)+import           Language.LSP.Protocol.Lens (command, range, title)+import           System.FilePath            ((<.>), (</>))+import           Test.Hls+import qualified Test.Hls.FileSystem        as FS++main :: IO ()+main = defaultTestRunner tests++evalPlugin :: PluginTestDescriptor Eval.Log+evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval"++tests :: TestTree+tests =+  testGroup "eval"+  [ testCase "Produces Evaluate code lenses" $+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do+        doc <- openDoc "T1.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."]+  , testCase "Produces Refresh code lenses" $+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do+        doc <- openDoc "T2.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."]+  , testCase "Code lenses have ranges" $+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do+        doc <- openDoc "T1.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]+  , testCase "Multi-line expressions have a multi-line range" $ do+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T3.hs") $ do+        doc <- openDoc "T3.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)]+  , testCase "Executed expressions range covers only the expression" $ do+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do+        doc <- openDoc "T2.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]++  , goldenWithEval "Evaluation of expressions" "T1" "hs"+  , goldenWithEval "Reevaluation of expressions" "T2" "hs"+  , goldenWithEval "Evaluation of expressions w/ imports" "T3" "hs"+  , goldenWithEval "Evaluation of expressions w/ lets" "T4" "hs"+  , goldenWithEval "Refresh an evaluation" "T5" "hs"+  , goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs"+  , goldenWithEval "Refresh a multiline evaluation" "T7" "hs"+  , goldenWithEval "Evaluate a multi-line show result" "TMultiResult" "hs" -- Do not escape from comments!+  , testCase "Semantic and Lexical errors are reported" $ do+      evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName"+      evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $+        if+           | ghcVersion >= GHC96 -> "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""+           | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""+           | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’"+           | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’"+      evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"+      evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False+  , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"+  , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (+        if ghcVersion >= GHC94 then "ghc94.expected"+        else if ghcVersion >= GHC92 then "ghc92.expected"+        else "expected"+      )+  , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069+  , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"+  , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"+  , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"+  , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs"+  , expectFailBecause "known issue - see a note in P.R. #361" $+      goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , testCase ":type handles a multilined result properly" $+      evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [+        "-- fun",+        if+           | ghcVersion >= GHC92 -> "--   :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."+           | ghcVersion == GHC90 -> "--   :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."+           | otherwise -> "--   :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",+        "--      (KnownNat k2, KnownNat n, Typeable a) =>",+        "--      Proxy k2 -> Proxy n -> Proxy a -> ()"+      ]+  , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs"+  , testCase ":type does \"dovetails\" for short identifiers" $+      evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [+        if+          | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."+          | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."+          | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",+        "--      (KnownNat k2, KnownNat n, Typeable a) =>",+        "--      Proxy k2 -> Proxy n -> Proxy a -> ()"+      ]+  , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs"+  , goldenWithEval ":kind treats a multilined result properly" "T25" "hs"+  , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs"+  , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs"+  , goldenWithEval "Multi line comments" "TMulti" "hs"+  , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs"+  , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs"+  , goldenWithEval "Evaluate expressions in Haddock comments in both single line and multi line format" "THaddock" "hs"+  , goldenWithEval "Compare results (for Haddock tests only)" "TCompare" "hs"+  , goldenWithEvalAndFs "Local Modules imports are accessible in a test" (FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) "TLocalImport" "hs"+  , goldenWithEvalAndFs "Transitive local dependency"  (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "TTransitive" "hs"+  -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs"+  , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs"+  , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else if ghcVersion >= GHC92 then "ghc92.expected" else "expected")+  , testCase ":set -fprint-explicit-foralls works" $ do+      evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"+      evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id"+        (if ghcVersion >= GHC92+           then "-- id :: forall a. a -> a"+           else "-- id :: forall {a}. a -> a")+  , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"+  , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"+  , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs"+  , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" (+        if ghcVersion >= GHC98 then+          "ghc98.expected"+        else if ghcVersion >= GHC96 then+          "ghc96.expected"+        else if ghcVersion >= GHC94 then+          "ghc94.expected"+        else+          "expected"+      )+  , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs"+  , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs"+  , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"+  , goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs"+  , testGroup "with preprocessors"+    [ knownBrokenInEnv [HostOS Windows]+        "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $+        goldenWithEval "CPP support" "TCPP" "hs"+    , goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs"+    ]+  , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs"+  , goldenWithEval "Variable 'it' works" "TIt" "hs"+  , testGroup "configuration"+    [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default"+    , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig+    , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False)+    , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True)+    ]+  , testGroup ":info command"+    [ testCase ":info reports type, constructors and instances" $ do+        [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs"+        "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"+        "Eq Foo" `isInfixOf` output                 @? "Output does not include instance Eq Foo"+        "Ord Foo" `isInfixOf` output                @? "Output does not include instance Ord Foo"+        not ("Baz Foo" `isInfixOf` output)          @? "Output includes instance Baz Foo"+    , testCase ":info reports type, constructors and instances for multiple types" $ do+        [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoMany.hs"+        "data Foo = Foo1 | Foo2" `isInfixOf` output        @? "Output does not include Foo data declaration"+        "Eq Foo" `isInfixOf` output                        @? "Output does not include instance Eq Foo"+        "Ord Foo" `isInfixOf` output                       @? "Output does not include instance Ord Foo"+        not ("Baz Foo" `isInfixOf` output)                 @? "Output includes instance Baz Foo"+        "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"+        "Eq Bar" `isInfixOf` output                        @? "Output does not include instance Eq Bar"+        "Ord Bar" `isInfixOf` output                       @? "Output does not include instance Ord Bar"+        not ("Baz Bar" `isInfixOf` output)                 @? "Output includes instance Baz Bar"+    , testCase ":info! reports type, constructors and unfiltered instances" $ do+        [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBang.hs"+        "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"+        "Eq Foo" `isInfixOf` output                 @? "Output does not include instance Eq Foo"+        "Ord Foo" `isInfixOf` output                @? "Output does not include instance Ord Foo"+        "Baz Foo" `isInfixOf` output                @? "Output does not include instance Baz Foo"+    , testCase ":info! reports type, constructors and unfiltered instances for multiple types" $ do+        [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBangMany.hs"+        "data Foo = Foo1 | Foo2" `isInfixOf` output        @? "Output does not include Foo data declaration"+        "Eq Foo" `isInfixOf` output                        @? "Output does not include instance Eq Foo"+        "Ord Foo" `isInfixOf` output                       @? "Output does not include instance Ord Foo"+        "Baz Foo" `isInfixOf` output                       @? "Output does not include instance Baz Foo"+        "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration"+        "Eq Bar" `isInfixOf` output                        @? "Output does not include instance Eq Bar"+        "Ord Bar" `isInfixOf` output                       @? "Output does not include instance Ord Bar"+        "Baz Bar" `isInfixOf` output                       @? "Output does not include instance Baz Bar"+    , testCase ":i behaves exactly the same as :info" $ do+        [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TI_Info.hs"+        "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration"+        "Eq Foo" `isInfixOf` output                 @? "Output does not include instance Eq Foo"+        "Ord Foo" `isInfixOf` output                @? "Output does not include instance Ord Foo"+        not ("Baz Foo" `isInfixOf` output)          @? "Output includes instance Baz Foo"+    ]+  , testCase "Interfaces are reused after Eval" $ do+      runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) $ do+        doc <- openDoc "TLocalImport.hs" "haskell"+        _ <- waitForTypecheck doc+        lenses <- getCodeLenses doc+        cmd <- liftIO $ case lenses^..folded.command._Just of+          [cmd] -> (cmd^.title @?= "Evaluate...") >> pure cmd+          cmds -> assertFailure $ "Expected a single command, got " <> show (length cmds)++        executeCmd cmd++        -- trigger a rebuild and check that dependency interfaces are not rebuilt+        changeDoc doc []+        _ <- waitForTypecheck doc+        Right keys <- getLastBuildKeys+        let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys+        liftIO $ ifaceKeys @?= []+  ]++goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree+goldenWithEval title path ext =+  goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards++goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree+goldenWithEvalAndFs title tree path ext =+  goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path  "expected" ext executeLensesBackwards++-- | Similar function as 'goldenWithEval' with an alternate reference file+-- naming. Useful when reference file may change because of GHC version.+goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree+goldenWithEval' title path ext expected =+  goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path expected ext executeLensesBackwards++goldenWithEvalAndFs' :: TestName -> [FS.FileTree] ->  FilePath -> FilePath -> FilePath -> TestTree+goldenWithEvalAndFs' title tree path ext expected =+  goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path expected ext executeLensesBackwards+++-- | Execute lenses backwards, to avoid affecting their position in the source file+executeLensesBackwards :: TextDocumentIdentifier -> Session ()+executeLensesBackwards doc = do+  codeLenses <- reverse <$> getCodeLenses doc+  -- liftIO $ print codeLenses++  -- Execute sequentially, nubbing elements to avoid+  -- evaluating the same section with multiple tests+  -- more than twice+  mapM_ executeCmd $+    nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses]++actSectionId :: Command -> Int+actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId+actSectionId _ = error "Invalid CodeLens"++-- Execute command and wait for result+executeCmd :: Command -> Session ()+executeCmd cmd = do+  executeCommand cmd+  _ <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+  -- liftIO $ print _resp+  pure ()++evalLenses :: FilePath -> IO [CodeLens]+evalLenses path = runSessionWithServerInTmpDir def evalPlugin (mkFs cabalProjectFS) $ do+  doc <- openDoc path "haskell"+  executeLensesBackwards doc+  getCodeLenses doc++codeLensTestOutput :: CodeLens -> [String]+codeLensTestOutput codeLens = do+  CodeLens { _command = Just command } <- [codeLens]+  Command { _arguments = Just args } <- [command]+  Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args+  Section { sectionTests = sectionTests } <- sections+  testOutput =<< sectionTests++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-eval-plugin" </> "test" </> "testdata"++changeConfig :: [Pair] -> Config+changeConfig conf =+  def+    { Plugin.plugins = Map.fromList [("eval",+        def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object conf }+    )] }+  where+    unObject (Object obj) = obj+    unObject _            = undefined++diffOffConfig :: Config+diffOffConfig = changeConfig ["diff" .= False]++exceptionConfig :: Bool -> Config+exceptionConfig exCfg = changeConfig ["exception" .= exCfg]++goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree+goldenWithEvalConfig' title path ext expected cfg =+  goldenWithHaskellDocInTmpDir cfg evalPlugin title (mkFs $ FS.directProject $ path <.> ext) path expected ext $ \doc -> do+    executeLensesBackwards doc++evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO ()+evalInFile fp e expected = runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject fp) $ do+  doc <- openDoc fp "haskell"+  origin <- documentContents doc+  let withEval = origin <> e+  changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval]+  executeLensesBackwards doc+  result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc+  liftIO $ result @?= Just (T.strip expected)++-- ----------------------------------------------------------------------------+-- File system definitions+-- Used for declaring a test file tree+-- ----------------------------------------------------------------------------++mkFs :: [FS.FileTree] -> FS.VirtualFileTree+mkFs = FS.mkVirtualFileTree testDataDir++cabalProjectFS :: [FS.FileTree]+cabalProjectFS = FS.simpleCabalProject'+  [ FS.copy "test.cabal"+  , FS.file "cabal.project"+      (FS.text "packages: ./info-util .\n"+      )+  , FS.copy "TProperty.hs"+  , FS.copy "TPropertyError.hs"+  , FS.copy "TI_Info.hs"+  , FS.copy "TInfo.hs"+  , FS.copy "TInfoBang.hs"+  , FS.copy "TInfoBangMany.hs"+  , FS.copy "TInfoMany.hs"+  , FS.directory "info-util"+    [ FS.copy "info-util/info-util.cabal"+    , FS.copy "info-util/InfoUtil.hs"+    ]+  ]
+ plugins/hls-eval-plugin/test/cabal.project view
@@ -0,0 +1,3 @@+packages:+  testdata/+  info-util/
+ plugins/hls-eval-plugin/test/testdata/T1.expected.hs view
@@ -0,0 +1,8 @@+module T1 where++import Data.List (unwords)++-- >>> unwords example+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T1.hs view
@@ -0,0 +1,7 @@+module T1 where++import Data.List (unwords)++-- >>> unwords example+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T10.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T10 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind! N + M + 1+-- N + M + 1 :: Nat+-- = 42
+ plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected view
@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T10 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind! N + M + 1+-- N + M + 1 :: Natural+-- = 42
+ plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T10 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind! N + M + 1+-- N + M + 1 :: Natural+-- = 42
+ plugins/hls-eval-plugin/test/testdata/T10.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T10 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind! N + M + 1
+ plugins/hls-eval-plugin/test/testdata/T11.expected.hs view
@@ -0,0 +1,4 @@+module T11 where++-- >>> :kind! A+-- Not in scope: type constructor or class ‘A’
+ plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs view
@@ -0,0 +1,4 @@+module T11 where++-- >>> :kind! A+-- Not in scope: type constructor or class `A'
+ plugins/hls-eval-plugin/test/testdata/T11.hs view
@@ -0,0 +1,3 @@+module T11 where++-- >>> :kind! A
+ plugins/hls-eval-plugin/test/testdata/T12.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1+-- N + M + 1 :: Nat
+ plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1+-- N + M + 1 :: Natural
+ plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1+-- N + M + 1 :: Natural
+ plugins/hls-eval-plugin/test/testdata/T12.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1
+ plugins/hls-eval-plugin/test/testdata/T13.expected.hs view
@@ -0,0 +1,4 @@+module T13 where++-- >>> :kind A+-- Not in scope: type constructor or class ‘A’
+ plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs view
@@ -0,0 +1,4 @@+module T13 where++-- >>> :kind A+-- Not in scope: type constructor or class `A'
+ plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs view
@@ -0,0 +1,4 @@+module T13 where++-- >>> :kind a+-- Not in scope: type variable `a'
+ plugins/hls-eval-plugin/test/testdata/T13.hs view
@@ -0,0 +1,3 @@+module T13 where++-- >>> :kind A
+ plugins/hls-eval-plugin/test/testdata/T14.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-}+module T14 where++foo :: Show a => a -> String+foo = show++-- >>> :type foo @Int+-- foo @Int :: Int -> String
+ plugins/hls-eval-plugin/test/testdata/T14.ghc98.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-}+module T14 where++foo :: Show a => a -> String+foo = show++-- >>> :type foo @Int+-- foo @Int :: Show Int => Int -> String
+ plugins/hls-eval-plugin/test/testdata/T14.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-}+module T14 where++foo :: Show a => a -> String+foo = show++-- >>> :type foo @Int
+ plugins/hls-eval-plugin/test/testdata/T15.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-}+module T15 where++foo :: Show a => a -> String+foo = show++-- >>> :type  +v  foo @Int+-- foo @Int :: Show Int => Int -> String
+ plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-}+module T15 where++foo :: Show a => a -> String+foo = show++-- >>> :type  +v  foo @Int+-- foo @Int :: Show Int => Int -> String
+ plugins/hls-eval-plugin/test/testdata/T15.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-}+module T15 where++foo :: Show a => a -> String+foo = show++-- >>> :type  +v  foo @Int
+ plugins/hls-eval-plugin/test/testdata/T16.expected.hs view
@@ -0,0 +1,4 @@+module T16 where++-- >>> :type  +d   40+ 2 +-- 40+ 2 :: Integer
+ plugins/hls-eval-plugin/test/testdata/T16.hs view
@@ -0,0 +1,3 @@+module T16 where++-- >>> :type  +d   40+ 2 
+ plugins/hls-eval-plugin/test/testdata/T17.expected.hs view
@@ -0,0 +1,4 @@+module T17 where++-- >>> :type  +no 42+-- parse error on input ‘+’
+ plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs view
@@ -0,0 +1,4 @@+module T17 where++-- >>> :type  +no 42+-- parse error on input `+'
+ plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs view
@@ -0,0 +1,4 @@+module T17 where++-- >>> :type  +no 42+-- parse error on input ‘+’
+ plugins/hls-eval-plugin/test/testdata/T17.hs view
@@ -0,0 +1,3 @@+module T17 where++-- >>> :type  +no 42
+ plugins/hls-eval-plugin/test/testdata/T18.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-}+module T18 where++-- >>> :noooop foo bar+-- unknown command 'noooop'
+ plugins/hls-eval-plugin/test/testdata/T18.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TypeApplications #-}+module T18 where++-- >>> :noooop foo bar
+ plugins/hls-eval-plugin/test/testdata/T19.expected.hs view
@@ -0,0 +1,7 @@+module T19 where+import Data.Word (Word)+type W = Word++-- >>> default (Word)+-- >>> :type  +d   40+ 2 +-- 40+ 2 :: Word
+ plugins/hls-eval-plugin/test/testdata/T19.hs view
@@ -0,0 +1,6 @@+module T19 where+import Data.Word (Word)+type W = Word++-- >>> default (Word)+-- >>> :type  +d   40+ 2 
+ plugins/hls-eval-plugin/test/testdata/T2.expected.hs view
@@ -0,0 +1,8 @@+module T2 where++import Data.List (unwords)++-- >>> unwords example+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T2.hs view
@@ -0,0 +1,8 @@+module T2 where++import Data.List (unwords)++-- >>> unwords example+-- "Stale output"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T20.expected.hs view
@@ -0,0 +1,7 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type  +d   40+ 2 +-- 40+ 2 :: Word
+ plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs view
@@ -0,0 +1,7 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type  +d   40+ 2 +-- 40+ 2 :: Word
+ plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs view
@@ -0,0 +1,7 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type  +d   40+ 2 +-- 40+ 2 :: Integer
+ plugins/hls-eval-plugin/test/testdata/T20.hs view
@@ -0,0 +1,6 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type  +d   40+ 2 
+ plugins/hls-eval-plugin/test/testdata/T21.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+module T21 where+import Data.Proxy (Proxy(..))+import GHC.TypeNats (KnownNat)+import Type.Reflection (Typeable)++fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a)+    => Proxy k -> Proxy n -> Proxy a -> ()+fun _ _ _ = ()+
+ plugins/hls-eval-plugin/test/testdata/T22.expected.hs view
@@ -0,0 +1,10 @@+module T22 where+import Data.Proxy      (Proxy (..))+import GHC.TypeNats    (KnownNat)+import Type.Reflection (Typeable)++f :: Integer+f = 32++-- >>> :t f+-- f :: Integer
+ plugins/hls-eval-plugin/test/testdata/T22.hs view
@@ -0,0 +1,9 @@+module T22 where+import Data.Proxy      (Proxy (..))+import GHC.TypeNats    (KnownNat)+import Type.Reflection (Typeable)++f :: Integer+f = 32++-- >>> :t f
+ plugins/hls-eval-plugin/test/testdata/T23.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+module T23 where+import Data.Proxy      (Proxy (..))+import GHC.TypeNats    (KnownNat)+import Type.Reflection (Typeable)++f :: forall k n a. (KnownNat k, KnownNat n, Typeable a)+  => Proxy k -> Proxy n -> Proxy a -> ()+f _ _ _ = ()+
+ plugins/hls-eval-plugin/test/testdata/T24.expected.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+module T24 where+import GHC.TypeNats (type (-))+data Proxy a = Stop | Next (Proxy a)++type family LongP n a where+  LongP 0 a = a+  LongP n a = Next (LongP (n - 1) a)++-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double)))))))))))))+-- ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy+--                                                                                                                                        (Proxy+--                                                                                                                                           (Proxy+--                                                                                                                                              (Proxy+--                                                                                                                                                 (Proxy+--                                                                                                                                                    (Proxy+--                                                                                                                                                       (Proxy+--                                                                                                                                                          (Proxy+--                                                                                                                                                             (Proxy+--                                                                                                                                                                (Proxy+--                                                                                                                                                                   (Proxy+--                                                                                                                                                                      (Proxy+--                                                                                                                                                                         (Proxy+--                                                                                                                                                                            Double))))))))))))+-- = 'Next+--     ('Next+--        ('Next+--           ('Next ('Next ('Next ('Next ('Next ('Next ('Next 'Stop)))))))))
+ plugins/hls-eval-plugin/test/testdata/T24.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+module T24 where+import GHC.TypeNats (type (-))+data Proxy a = Stop | Next (Proxy a)++type family LongP n a where+  LongP 0 a = a+  LongP n a = Next (LongP (n - 1) a)++-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double)))))))))))))
+ plugins/hls-eval-plugin/test/testdata/T25.expected.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+module T25 where+import GHC.TypeNats (type (-))+data Proxy a = Stop | Next (Proxy a)++type family LongP n a where+  LongP 0 a = a+  LongP n a = Next (LongP (n - 1) a)++-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double)))))))))))))+-- (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy+--                                                                                                                             (Proxy+--                                                                                                                                (Proxy+--                                                                                                                                   (Proxy+--                                                                                                                                      (Proxy+--                                                                                                                                         (Proxy+--                                                                                                                                            (Proxy+--                                                                                                                                               (Proxy+--                                                                                                                                                  (Proxy+--                                                                                                                                                     (Proxy+--                                                                                                                                                        (Proxy+--                                                                                                                                                           (Proxy+--                                                                                                                                                              (Proxy+--                                                                                                                                                                 Double))))))))))))
+ plugins/hls-eval-plugin/test/testdata/T25.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+module T25 where+import GHC.TypeNats (type (-))+data Proxy a = Stop | Next (Proxy a)++type family LongP n a where+  LongP 0 a = a+  LongP n a = Next (LongP (n - 1) a)++-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double)))))))))))))
+ plugins/hls-eval-plugin/test/testdata/T26.expected.hs view
@@ -0,0 +1,5 @@+module T26 where+import Util ()++-- >>> "hello"+-- "hello"
+ plugins/hls-eval-plugin/test/testdata/T26.hs view
@@ -0,0 +1,4 @@+module T26 where+import Util ()++-- >>> "hello"
+ plugins/hls-eval-plugin/test/testdata/T27.expected.hs view
@@ -0,0 +1,5 @@+module T27 where++-- >>> ()+-- ()+--
+ plugins/hls-eval-plugin/test/testdata/T27.hs view
@@ -0,0 +1,4 @@+module T27 where++-- >>> ()+--
+ plugins/hls-eval-plugin/test/testdata/T3.expected.hs view
@@ -0,0 +1,8 @@+module T3 where+++-- >>> import Data.List (unwords)+-- >>> unwords example+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T3.hs view
@@ -0,0 +1,7 @@+module T3 where+++-- >>> import Data.List (unwords)+-- >>> unwords example+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T4.expected.hs view
@@ -0,0 +1,10 @@+module T4 where++import           Data.List (unwords)++-- >>> let evaluation = " evaluation"+-- >>> unwords example ++ evaluation+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of"]+
+ plugins/hls-eval-plugin/test/testdata/T4.hs view
@@ -0,0 +1,9 @@+module T4 where++import           Data.List (unwords)++-- >>> let evaluation = " evaluation"+-- >>> unwords example ++ evaluation+example :: [String]+example = ["This","is","an","example","of"]+
+ plugins/hls-eval-plugin/test/testdata/T5.expected.hs view
@@ -0,0 +1,6 @@+module T5 where++-- >>> unwords example+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T5.hs view
@@ -0,0 +1,6 @@+module T5 where++-- >>> unwords example+-- "This is a stale example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/T6.expected.hs view
@@ -0,0 +1,9 @@+module T6 where++import Data.List (unwords)++-- >>> let evaluation = " evaluation"+-- >>> unwords example ++ evaluation+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of"]
+ plugins/hls-eval-plugin/test/testdata/T6.hs view
@@ -0,0 +1,9 @@+module T6 where++import Data.List (unwords)++-- >>> let evaluation = " evaluation"+-- >>> unwords example ++ evaluation+-- "This is a stale example of evaluation"+example :: [String]+example = ["This","is","an","example","of"]
+ plugins/hls-eval-plugin/test/testdata/T7.expected.hs view
@@ -0,0 +1,10 @@+module T7 where++import Data.List (unwords)++-- >>> --+-- >>> --+-- >>> unwords example+-- "This is an example of"+example :: [String]+example = ["This","is","an","example","of"]
+ plugins/hls-eval-plugin/test/testdata/T7.hs view
@@ -0,0 +1,10 @@+module T7 where++import Data.List (unwords)++-- >>> --+-- >>> --+-- >>> unwords example+-- "This is a stale example of"+example :: [String]+example = ["This","is","an","example","of"]
+ plugins/hls-eval-plugin/test/testdata/T8.hs view
@@ -0,0 +1,2 @@+-- An empty playground+module T8 where
+ plugins/hls-eval-plugin/test/testdata/T9.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+module T9 where+import Data.Proxy (Proxy(..))++type P = Proxy++-- >>> Proxy :: Proxy 3+-- Proxy
+ plugins/hls-eval-plugin/test/testdata/T9.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DataKinds #-}+module T9 where+import Data.Proxy (Proxy(..))++type P = Proxy++-- >>> Proxy :: Proxy 3
+ plugins/hls-eval-plugin/test/testdata/TCPP.expected.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module TCPP where++-- >>> y+-- 11+y :: Integer+y = 11++#define ALL++#ifdef ALL+-- >>> 3+y+-- 14+#else+-- >>> 5+y+#endif++-- >>> 2+y+-- 13
+ plugins/hls-eval-plugin/test/testdata/TCPP.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module TCPP where++-- >>> y+y :: Integer+y = 11++#define ALL++#ifdef ALL+-- >>> 3+y+#else+-- >>> 5+y+#endif++-- >>> 2+y
+ plugins/hls-eval-plugin/test/testdata/TCompare.expected.hs view
@@ -0,0 +1,13 @@+module TCompare where++-- In plain comments, the previous result of an evaluation is simply replaced++-- >>> 2+2+-- 4++-- In Haddock comments, the previous result of an evaluation is compared with the new one+-- and difference are displayed++-- | >>> 2+2+-- WAS 5+-- NOW 4
+ plugins/hls-eval-plugin/test/testdata/TCompare.hs view
@@ -0,0 +1,12 @@+module TCompare where++-- In plain comments, the previous result of an evaluation is simply replaced++-- >>> 2+2+-- 5++-- In Haddock comments, the previous result of an evaluation is compared with the new one+-- and difference are displayed++-- | >>> 2+2+-- 5
+ plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs view
@@ -0,0 +1,8 @@+module TDiff where++-- |+-- >>> myId 5+-- WAS 4+-- NOW 5+myId :: a -> a+myId x = x
+ plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs view
@@ -0,0 +1,7 @@+module TDiff where++-- |+-- >>> myId 5+-- 5+myId :: a -> a+myId x = x
+ plugins/hls-eval-plugin/test/testdata/TDiff.hs view
@@ -0,0 +1,7 @@+module TDiff where++-- |+-- >>> myId 5+-- 4+myId :: a -> a+myId x = x
+ plugins/hls-eval-plugin/test/testdata/TEndingMulti.expected.hs view
@@ -0,0 +1,9 @@+module TEndingMulti where++-- Now trailing doctest is allowed:++{- >>> 42+>>> 54+42+54+-}
+ plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs view
@@ -0,0 +1,6 @@+module TEndingMulti where++-- Now trailing doctest is allowed:++{- >>> 42+>>> 54-}
+ plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs view
@@ -0,0 +1,6 @@+module TException where++-- >>> exceptionalCode+-- *** Exception: I am exceptional!+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs view
@@ -0,0 +1,6 @@+module TException where++-- >>> exceptionalCode+-- I am exceptional!+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ plugins/hls-eval-plugin/test/testdata/TException.hs view
@@ -0,0 +1,5 @@+module TException where++-- >>> exceptionalCode+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs view
@@ -0,0 +1,62 @@+-- Support for language options++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Haskell2010 #-}++module TFlags where++-- Language options set in the module source (ScopedTypeVariables)+-- also apply to tests so this works fine+-- >>> f = (\(c::Char) -> [c])++{- Multiple options can be set with a single `:set`++>>> :set -XMultiParamTypeClasses -XFlexibleInstances+>>> class Z a b c+-}++{-++Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:++>>> class L a b c+Too many parameters for class ‘L’+(Enable MultiParamTypeClasses to allow multi-parameter classes)+-}+++{-+Options apply to all tests in the same section after their declaration.++Not set yet:++>>> class D+No parameters for class ‘D’+(Enable MultiParamTypeClasses to allow no-parameter classes)++Now it works:++>>>:set -XMultiParamTypeClasses+>>> class C++It still works++>>> class F+-}++{- Now -package flag is handled correctly:++>>> :set -package ghc-prim+>>> import GHC.Prim++-}+++{- Invalid option/flags are reported, but valid ones will be reflected++>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all+<interactive>: warning:+    -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.+Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all++-}
+ plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs view
@@ -0,0 +1,64 @@+-- Support for language options++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Haskell2010 #-}++module TFlags where++-- Language options set in the module source (ScopedTypeVariables)+-- also apply to tests so this works fine+-- >>> f = (\(c::Char) -> [c])++{- Multiple options can be set with a single `:set`++>>> :set -XMultiParamTypeClasses -XFlexibleInstances+>>> class Z a b c+-}++{-++Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:++>>> class L a b c+Too many parameters for class `L'+(Enable MultiParamTypeClasses to allow multi-parameter classes)+In the class declaration for `L'+-}+++{-+Options apply to all tests in the same section after their declaration.++Not set yet:++>>> class D+No parameters for class `D'+(Enable MultiParamTypeClasses to allow no-parameter classes)+In the class declaration for `D'++Now it works:++>>>:set -XMultiParamTypeClasses+>>> class C++It still works++>>> class F+-}++{- Now -package flag is handled correctly:++>>> :set -package ghc-prim+>>> import GHC.Prim++-}+++{- Invalid option/flags are reported, but valid ones will be reflected++>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all+<interactive>: warning:+    -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.+Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all++-}
+ plugins/hls-eval-plugin/test/testdata/TFlags.ghc98.expected.hs view
@@ -0,0 +1,62 @@+-- Support for language options++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Haskell2010 #-}++module TFlags where++-- Language options set in the module source (ScopedTypeVariables)+-- also apply to tests so this works fine+-- >>> f = (\(c::Char) -> [c])++{- Multiple options can be set with a single `:set`++>>> :set -XMultiParamTypeClasses -XFlexibleInstances+>>> class Z a b c+-}++{-++Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:++>>> class L a b c+Too many parameters for class `L'+In the class declaration for `L'+-}+++{-+Options apply to all tests in the same section after their declaration.++Not set yet:++>>> class D+No parameters for class `D'+In the class declaration for `D'++Now it works:++>>>:set -XMultiParamTypeClasses+>>> class C++It still works++>>> class F+-}++{- Now -package flag is handled correctly:++>>> :set -package ghc-prim+>>> import GHC.Prim++-}+++{- Invalid option/flags are reported, but valid ones will be reflected++>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all+<interactive>: warning: [GHC-53692] [-Wdeprecated-flags (in -Wdefault)]+    -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.+Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all++-}
+ plugins/hls-eval-plugin/test/testdata/TFlags.hs view
@@ -0,0 +1,55 @@+-- Support for language options++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Haskell2010 #-}++module TFlags where++-- Language options set in the module source (ScopedTypeVariables)+-- also apply to tests so this works fine+-- >>> f = (\(c::Char) -> [c])++{- Multiple options can be set with a single `:set`++>>> :set -XMultiParamTypeClasses -XFlexibleInstances+>>> class Z a b c+-}++{-++Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:++>>> class L a b c+-}+++{-+Options apply to all tests in the same section after their declaration.++Not set yet:++>>> class D++Now it works:++>>>:set -XMultiParamTypeClasses+>>> class C++It still works++>>> class F+-}++{- Now -package flag is handled correctly:++>>> :set -package ghc-prim+>>> import GHC.Prim++-}+++{- Invalid option/flags are reported, but valid ones will be reflected++>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all++-}
+ plugins/hls-eval-plugin/test/testdata/THaddock.expected.hs view
@@ -0,0 +1,42 @@+{- |+Tests in plain comments in both single line or multi line format, both forward and backward.+Tests are ignored if:+    * do not start on the first column (in Ordinary Haskell)+    * do not start on the first or second column (in Literate Haskell)+-}+module THaddock () where++{- ORMOLU_DISABLE -}++-- | Single line comment+-- >>> "a"++"b"+-- "ab"++{- | Multi line comment++>>> "b"++"c"+"bc"+-}++double :: Num a => a -> a+double a = a + a+-- ^ Single line backward comments+-- >>> double 11+-- 22++twice :: [a] -> [a]+twice a = a ++ a+{- ^ Multi-line backward comments+>>> twice "ABC"+"ABCABC"+-}++{- | >>> 2+five+7++   ^-- This works, as it starts at the first column after the header.++     >>> IGNORED as it does not start on the first column+-}+five :: Integer+five = 5
+ plugins/hls-eval-plugin/test/testdata/THaddock.hs view
@@ -0,0 +1,37 @@+{- |+Tests in plain comments in both single line or multi line format, both forward and backward.+Tests are ignored if:+    * do not start on the first column (in Ordinary Haskell)+    * do not start on the first or second column (in Literate Haskell)+-}+module THaddock () where++{- ORMOLU_DISABLE -}++-- | Single line comment+-- >>> "a"++"b"++{- | Multi line comment++>>> "b"++"c"+-}++double :: Num a => a -> a+double a = a + a+-- ^ Single line backward comments+-- >>> double 11++twice :: [a] -> [a]+twice a = a ++ a+{- ^ Multi-line backward comments+>>> twice "ABC"+-}++{- | >>> 2+five++   ^-- This works, as it starts at the first column after the header.++     >>> IGNORED as it does not start on the first column+-}+five :: Integer+five = 5
+ plugins/hls-eval-plugin/test/testdata/TIO.expected.hs view
@@ -0,0 +1,9 @@+-- IO expressions are supported, stdout/stderr output is ignored+module TIO where++{-+Does not capture stdout, returns value.++>>> print "ABC" >> return "XYZ"+"XYZ"+-}
+ plugins/hls-eval-plugin/test/testdata/TIO.hs view
@@ -0,0 +1,9 @@+-- IO expressions are supported, stdout/stderr output is ignored+module TIO where++{-+Does not capture stdout, returns value.++>>> print "ABC" >> return "XYZ"+"XYZ"+-}
+ plugins/hls-eval-plugin/test/testdata/TI_Info.hs view
@@ -0,0 +1,5 @@+module TI_Info (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :i Foo
+ plugins/hls-eval-plugin/test/testdata/TInfo.hs view
@@ -0,0 +1,5 @@+module TInfo (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :info Foo
+ plugins/hls-eval-plugin/test/testdata/TInfoBang.hs view
@@ -0,0 +1,5 @@+module TInfoBang (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :info! Foo
+ plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs view
@@ -0,0 +1,5 @@+module TInfoBangMany (Eq, Ord, Foo, Bar) where++import InfoUtil (Eq, Ord, Foo, Bar)++-- >>> :info! Foo Bar
+ plugins/hls-eval-plugin/test/testdata/TInfoMany.hs view
@@ -0,0 +1,5 @@+module TInfoMany (Eq, Ord, Foo, Bar) where++import InfoUtil (Eq, Ord, Foo, Bar)++-- >>> :info Foo Bar
+ plugins/hls-eval-plugin/test/testdata/TIt.expected.hs view
@@ -0,0 +1,11 @@+module TIt where++-- >>> "test"+-- >>> it+-- "test"+-- "test"++-- >>> pure "test2"+-- >>> it+-- "test2"+-- "test2"
+ plugins/hls-eval-plugin/test/testdata/TIt.hs view
@@ -0,0 +1,7 @@+module TIt where++-- >>> "test"+-- >>> it++-- >>> pure "test2"+-- >>> it
+ plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.expected.hs view
@@ -0,0 +1,9 @@+-- This works fine: {-# LANGUAGE TupleSections #-}+module TLanguageOptionsTupleSections where++-- Why oh why is this not working?+-- What is special about TupleSections?+-- >>> :set -XTupleSections+-- >>> ("a",) "b"+-- ("a","b")+
+ plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.hs view
@@ -0,0 +1,9 @@+-- This works fine: {-# LANGUAGE TupleSections #-}+module TLanguageOptionsTupleSections where++-- Why oh why is this not working?+-- What is special about TupleSections?+-- >>> :set -XTupleSections+-- >>> ("a",) "b"+-- ("a","b")+
+ plugins/hls-eval-plugin/test/testdata/TLastLine.expected.hs view
@@ -0,0 +1,4 @@+module TLastLine where++-- >>> take 3 [1..]+-- [1,2,3]
+ plugins/hls-eval-plugin/test/testdata/TLastLine.hs view
@@ -0,0 +1,3 @@+module TLastLine where++-- >>> take 3 [1..]
+ plugins/hls-eval-plugin/test/testdata/TLocalImport.expected.hs view
@@ -0,0 +1,9 @@+module TLocalImport where++import qualified Util++-- >>> Util.tst 11 11+-- True++tst' :: Eq a => a -> a -> Bool+tst' = Util.tst
+ plugins/hls-eval-plugin/test/testdata/TLocalImport.hs view
@@ -0,0 +1,8 @@+module TLocalImport where++import qualified Util++-- >>> Util.tst 11 11++tst' :: Eq a => a -> a -> Bool+tst' = Util.tst
+ plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.expected.hs view
@@ -0,0 +1,5 @@+module TLocalImportInTest where++-- >>> import qualified Util+-- >>> Util.a+-- 'a'
+ plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.hs view
@@ -0,0 +1,4 @@+module TLocalImportInTest where++-- >>> import qualified Util+-- >>> Util.a
+ plugins/hls-eval-plugin/test/testdata/TMulti.expected.hs view
@@ -0,0 +1,25 @@+{- | Multi line comments are parsed correctly.+-}+module TMulti () where++{- ORMOLU_DISABLE -}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"+-- "ab"++  {- >>> 3+3+6+    -}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"+-- "ab"++  {-| >>> "NOT IGNORED" +"NOT IGNORED"+-}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"+-- "ab"
+ plugins/hls-eval-plugin/test/testdata/TMulti.hs view
@@ -0,0 +1,19 @@+{- | Multi line comments are parsed correctly.+-}+module TMulti () where++{- ORMOLU_DISABLE -}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"++  {- >>> 3+3+    -}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"++  {-| >>> "NOT IGNORED" -}++-- this should work fine if previous multi comment is parsed correctly+-- >>> "a"++"b"
+ plugins/hls-eval-plugin/test/testdata/TMultiResult.expected.hs view
@@ -0,0 +1,13 @@+module TMultiResult where+-- test multiline show instance (see #2907)++data Multiline = M {l1 :: String, l2 :: String} deriving Read++instance Show Multiline where+  show m = "M {\n  l1=" <> show (l1 m) <> ",\n  l2=" <> show (l2 m) <> "\n}"++-- >>> M "first line" "second line"+-- M {+--   l1="first line",+--   l2="second line"+-- }
+ plugins/hls-eval-plugin/test/testdata/TMultiResult.hs view
@@ -0,0 +1,9 @@+module TMultiResult where+-- test multiline show instance (see #2907)++data Multiline = M {l1 :: String, l2 :: String} deriving Read++instance Show Multiline where+  show m = "M {\n  l1=" <> show (l1 m) <> ",\n  l2=" <> show (l2 m) <> "\n}"++-- >>> M "first line" "second line"
+ plugins/hls-eval-plugin/test/testdata/TNested.expected.hs view
@@ -0,0 +1,15 @@+module TNested () where+{-+>>> 54+54+{-+Nested+-}+-}++{-+{-+>>> 42+42+-}+-}
+ plugins/hls-eval-plugin/test/testdata/TNested.hs view
@@ -0,0 +1,13 @@+module TNested () where+{-+>>> 54+{-+Nested+-}+-}++{-+{-+>>> 42+-}+-}
+ plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++module TNoImplicitPrelude where++import Data.List (unwords)+import Data.String (String)++-- >>> unwords example+-- "This is an example of evaluation"+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++module TNoImplicitPrelude where++import Data.List (unwords)+import Data.String (String)++-- >>> unwords example+example :: [String]+example = ["This","is","an","example","of","evaluation"]
+ plugins/hls-eval-plugin/test/testdata/TPlainComment.expected.hs view
@@ -0,0 +1,29 @@+{- |+Tests in plain comments in both single line or multi line format.+Tests are ignored if:+    * do not start on the first column+    * are in multi line comments that open and close on the same line+-}+module TPlainComment where++{- ORMOLU_DISABLE -}++-- Single line comment+-- >>> "a"++"b"+-- "ab"++{- Multi line comment++>>> "b"++"c"+"bc"+-}++{- >>> 2+five+7++   ^-- This works, as it starts at the first column after the header.++     >>> IGNORED as it does not start on the first column+-}+five :: Integer+five = 5
+ plugins/hls-eval-plugin/test/testdata/TPlainComment.hs view
@@ -0,0 +1,26 @@+{- |+Tests in plain comments in both single line or multi line format.+Tests are ignored if:+    * do not start on the first column+    * are in multi line comments that open and close on the same line+-}+module TPlainComment where++{- ORMOLU_DISABLE -}++-- Single line comment+-- >>> "a"++"b"++{- Multi line comment++>>> "b"++"c"+-}++{- >>> 2+five++   ^-- This works, as it starts at the first column after the header.++     >>> IGNORED as it does not start on the first column+-}+five :: Integer+five = 5
+ plugins/hls-eval-plugin/test/testdata/TPrelude.expected.hs view
@@ -0,0 +1,11 @@+-- Prelude has no special treatment, it is imported as stated in the module.+module TPrelude where++import           Prelude hiding (foldr)++-- >>> foldr (+) 10 [2,3,5]+-- 20+foldr :: (a -> z -> z) -> z -> [a] -> z+foldr f z bs =+   (foldl (\g a -> g . f a) id bs) z+
+ plugins/hls-eval-plugin/test/testdata/TPrelude.hs view
@@ -0,0 +1,10 @@+-- Prelude has no special treatment, it is imported as stated in the module.+module TPrelude where++import           Prelude hiding (foldr)++-- >>> foldr (+) 10 [2,3,5]+foldr :: (a -> z -> z) -> z -> [a] -> z+foldr f z bs =+   (foldl (\g a -> g . f a) id bs) z+
+ plugins/hls-eval-plugin/test/testdata/TProperty.expected.hs view
@@ -0,0 +1,6 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> reverse (reverse l) == l+-- +++ OK, passed 100 tests.+
+ plugins/hls-eval-plugin/test/testdata/TProperty.hs view
@@ -0,0 +1,5 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> reverse (reverse l) == l+
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs view
@@ -0,0 +1,6 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test):+-- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs view
@@ -0,0 +1,13 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! (after 1 test):+-- Exception:+--   Prelude.head: empty list+--   CallStack (from HasCallStack):+--     error, called at libraries/base/GHC/List.hs:1646:3 in base:GHC.List+--     errorEmptyList, called at libraries/base/GHC/List.hs:85:11 in base:GHC.List+--     badHead, called at libraries/base/GHC/List.hs:81:28 in base:GHC.List+--     head, called at <interactive>:1:27 in interactive:Ghci2+-- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc96.expected.hs view
@@ -0,0 +1,13 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! (after 1 test):+-- Exception:+--   Prelude.head: empty list+--   CallStack (from HasCallStack):+--     error, called at libraries/base/GHC/List.hs:1644:3 in base:GHC.List+--     errorEmptyList, called at libraries/base/GHC/List.hs:87:11 in base:GHC.List+--     badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List+--     head, called at <interactive>:1:27 in interactive:Ghci2+-- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs view
@@ -0,0 +1,13 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! (after 1 test):+-- Exception:+--   Prelude.head: empty list+--   CallStack (from HasCallStack):+--     error, called at libraries/base/GHC/List.hs:1782:3 in base:GHC.List+--     errorEmptyList, called at libraries/base/GHC/List.hs:89:11 in base:GHC.List+--     badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List+--     head, called at <interactive>:1:27 in interactive:Ghci2+-- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.hs view
@@ -0,0 +1,4 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l
+ plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs view
@@ -0,0 +1,27 @@+-- The default language extensions for the eval plugin are the same as those for ghci++module TSameDefaultLanguageExtensionsAsGhci where++{-+Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation.++The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci.+(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483)++It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only.+-}+++-- ExtendedDefaultRules++-- >>> []+-- []++-- >>> reverse []+-- []++-- NoMonomorphismRestriction++-- >>> plus = (+)+-- >>> :t plus+-- plus :: Num a => a -> a -> a
+ plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs view
@@ -0,0 +1,24 @@+-- The default language extensions for the eval plugin are the same as those for ghci++module TSameDefaultLanguageExtensionsAsGhci where++{-+Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation.++The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci.+(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483)++It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only.+-}+++-- ExtendedDefaultRules++-- >>> []++-- >>> reverse []++-- NoMonomorphismRestriction++-- >>> plus = (+)+-- >>> :t plus
+ plugins/hls-eval-plugin/test/testdata/TSectionEval.expected.hs view
@@ -0,0 +1,17 @@+-- Tests in the same document section are executed together+module TSectionEval where++{-+>>> 1+1+2++>>> 2+2+4+-}++{-+>>> 3+3++>>> 4+4+-}+
+ plugins/hls-eval-plugin/test/testdata/TSectionEval.hs view
@@ -0,0 +1,15 @@+-- Tests in the same document section are executed together+module TSectionEval where++{-+>>> 1+1++>>> 2+2+-}++{-+>>> 3+3++>>> 4+4+-}+
+ plugins/hls-eval-plugin/test/testdata/TSetup.expected.hs view
@@ -0,0 +1,12 @@+-- The setup section is executed before any other test+module TSetup where++-- $setup+-- >>> x=11+-- >>> y=22++-- >>> x+y+-- 33++-- >>> x*y+-- 242
+ plugins/hls-eval-plugin/test/testdata/TSetup.hs view
@@ -0,0 +1,10 @@+-- The setup section is executed before any other test+module TSetup where++-- $setup+-- >>> x=11+-- >>> y=22++-- >>> x+y++-- >>> x*y
+ plugins/hls-eval-plugin/test/testdata/TTransitive.expected.hs view
@@ -0,0 +1,6 @@+module TTransitive where++import TLocalImport++-- >>> tst' 11 11+-- True
+ plugins/hls-eval-plugin/test/testdata/TTransitive.hs view
@@ -0,0 +1,5 @@+module TTransitive where++import TLocalImport++-- >>> tst' 11 11
+ plugins/hls-eval-plugin/test/testdata/TUNPACK.expected.hs view
@@ -0,0 +1,14 @@+{- | Won't panic on UNPACKs -}+module TUNPACK (THStatus(..)) where++type ByteString = String+type BSEndo = ByteString -> ByteString+type BSEndoList = [ByteString] -> [ByteString]++data THStatus = THStatus+    {-# UNPACK #-} !Int -- running total byte count+    BSEndoList -- previously parsed lines+    BSEndo -- bytestrings to be prepended++-- >>> "Yay! UNPACK pragma didn't do bad things!"+-- "Yay! UNPACK pragma didn't do bad things!"
+ plugins/hls-eval-plugin/test/testdata/TUNPACK.hs view
@@ -0,0 +1,13 @@+{- | Won't panic on UNPACKs -}+module TUNPACK (THStatus(..)) where++type ByteString = String+type BSEndo = ByteString -> ByteString+type BSEndoList = [ByteString] -> [ByteString]++data THStatus = THStatus+    {-# UNPACK #-} !Int -- running total byte count+    BSEndoList -- previously parsed lines+    BSEndo -- bytestrings to be prepended++-- >>> "Yay! UNPACK pragma didn't do bad things!"
+ plugins/hls-eval-plugin/test/testdata/Util.hs view
@@ -0,0 +1,13 @@+-- Used for testing local imports+module Util+  ( tst+  , a+  , b+  )+where++tst a b = a == b++a = 'a'++b = 'b'
+ plugins/hls-eval-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,4 @@+cradle:+  cabal:+    - path: "./"+      component: "lib:test"
+ plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs view
@@ -0,0 +1,20 @@+module InfoUtil+  ( Eq+  , Ord+  , Foo (..)+  , Bar (..)+  , Baz+  )+where++import           Prelude (Eq, Ord)++data Foo = Foo1 | Foo2+  deriving (Eq, Ord)++data Bar = Bar1 | Bar2 | Bar3+  deriving (Eq, Ord)++class Baz t+instance Baz Foo+instance Baz Bar
+ plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal view
@@ -0,0 +1,18 @@+name:                info-util+version:             0.1.0.0+-- synopsis:+-- description:+license:             BSD3+author:              Author name here+maintainer:          example@example.com+copyright:           2017 Author name here+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:+    InfoUtil+  build-depends:       base >= 4.7 && < 5+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-unused-imports
+ plugins/hls-eval-plugin/test/testdata/test.cabal view
@@ -0,0 +1,25 @@+name:                test+version:             0.1.0.0+-- synopsis:+-- description:+license:             BSD3+author:              Author name here+maintainer:          example@example.com+copyright:           2017 Author name here+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:+      TProperty+      TPropertyError+      TInfo+      TInfoMany+      TInfoBang+      TInfoBangMany+      TI_Info++  build-depends:       base >= 4.7 && < 5, QuickCheck, info-util+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-unused-imports
+ plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Ide.Plugin.ExplicitFixity(descriptor, Log) where++import           Control.DeepSeq+import           Control.Monad.IO.Class               (MonadIO, liftIO)+import           Data.Either.Extra+import           Data.Hashable+import qualified Data.Map.Strict                      as M+import           Data.Maybe+import qualified Data.Set                             as S+import qualified Data.Text                            as T+import           Development.IDE                      hiding (pluginHandlers,+                                                       pluginRules)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (idDelta)+import           Development.IDE.Core.Shake           (addPersistentRule)+import qualified Development.IDE.Core.Shake           as Shake+import           Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util      as Util+import           Development.IDE.LSP.Notifications    (ghcideNotificationsPluginPriority)+import           Development.IDE.Spans.AtPoint+import           GHC.Generics                         (Generic)+import           Ide.Plugin.Error+import           Ide.Types                            hiding (pluginId)+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides fixity information in hovers")+    { pluginRules = fixityRule recorder+    , pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover+    -- Make this plugin has a lower priority than ghcide's plugin to ensure+    -- type info display first.+    , pluginPriority = ghcideNotificationsPluginPriority - 1+    }++hover :: PluginMethodHandler IdeState Method_TextDocumentHover+hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = do+    nfp <- getNormalizedFilePathE uri+    runIdeActionE "ExplicitFixity" (shakeExtras state) $ do+      (FixityMap fixmap, _) <-  useWithStaleFastE GetFixity nfp+      (HAR{hieAst}, mapping) <- useWithStaleFastE GetHieAst nfp+      let ns = getNamesAtPoint hieAst pos mapping+          fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns+      pure $ maybeToNull $ toHover fs+    where+        toHover :: [(Name, Fixity)] -> Maybe Hover+        toHover [] = Nothing+        toHover fixities =+            let -- Splicing fixity info+                contents = T.intercalate "\n\n" $ fixityText <$> fixities+                -- Append to the previous hover content+                contents' = "\n" <> sectionSeparator <> contents+            in  Just $ Hover (InL (mkPlainText contents')) Nothing++        fixityText :: (Name, Fixity) -> T.Text+        fixityText (name, Fixity _ precedence direction) =+            printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`"++newtype FixityMap = FixityMap (M.Map Name Fixity)+instance Show FixityMap where+  show _ = "FixityMap"++instance NFData FixityMap where+  rnf (FixityMap xs) = rnf xs++instance NFData Fixity where+  rnf = rwhnf++newtype Log = LogShake Shake.Log++instance Pretty Log where+    pretty = \case+        LogShake log -> pretty log++data GetFixity = GetFixity deriving (Show, Eq, Generic)++instance Hashable GetFixity+instance NFData GetFixity++type instance RuleResult GetFixity = FixityMap++-- | Convert a HieAST to FixityTree with fixity info gathered+lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity)+lookupFixities hscEnv tcGblEnv names+    = liftIO+    $ fmap (fromMaybe M.empty . snd)+    $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1)+    $ M.traverseMaybeWithKey (\_ v -> v)+    $ M.fromSet lookupFixity names+  where+    lookupFixity name = do+      f <- Util.handleGhcException+        (const $ pure Nothing)+        (Just <$> lookupFixityRn name)+      if f == Just defaultFixity+      then pure Nothing+      else pure f++fixityRule :: Recorder (WithPriority Log) -> Rules ()+fixityRule recorder = do+    define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do+        HAR{refMap} <- use_ GetHieAst nfp+        env <- hscEnv <$> use_ GhcSessionDeps nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates+        tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp+        fs <- lookupFixities env tcGblEnv (S.mapMonotonic (\(Right n) -> n) $ S.filter isRight $ M.keysSet refMap)+        pure ([], Just (FixityMap fs))++    -- Ensure that this plugin doesn't block on startup+    addPersistentRule GetFixity $ \_ -> pure $ Just (FixityMap M.empty, idDelta, Nothing)
+ plugins/hls-explicit-fixity-plugin/test/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.Text                 as T+import           Ide.Plugin.ExplicitFixity (Log, descriptor)+import           System.FilePath+import           Test.Hls++plugin :: PluginTestDescriptor Log+plugin = mkPluginTestDescriptor descriptor "explicit-fixity"++main :: IO ()+main = defaultTestRunner tests++tests :: TestTree+tests = testGroup "Explicit fixity"+    [ hoverTest "(++)" (Position 5 7) "infixr 5 `++`"+    , hoverTest "($)" (Position 6 7) "infixr 0 `$`"+    , hoverTest "(.)" (Position 7 7) "infixr 9 `.`"+    , hoverTest "(+)" (Position 8 7) "infixl 6 `+`"+    , hoverTest "(-)" (Position 9 8) "infixl 6 `-`"+    , hoverTest "(<>)" (Position 10 7) "infixr 6 `<>`"+    , hoverTest "(>>=)" (Position 11 7) "infixl 1 `>>=`"+    , hoverTest "(>=>)" (Position 12 7) "infixr 1 `>=>`"+    , hoverTest "elem" (Position 13 7) "infix 4 `elem`"+    , hoverTest "on" (Position 14 7) "infixl 0 `on`"+    , hoverTest "(||)" (Position 15 8) "infixr 2 `||`"+    , hoverTest "mod" (Position 16 8) "infixl 7 `mod`"+    , hoverTest "(**)" (Position 17 8) "infixr 8 `**`"+    , hoverTest "(^)" (Position 18 8) "infixr 8 `^`"+    , hoverTest "(<$)" (Position 19 8) "infixl 4 `<$`"+    , hoverTest "seq" (Position 20 9) "infixr 0 `seq`"+    , hoverTest "(<|>)" (Position 21 8) "infixl 3 `<|>`"+    , hoverTest "fixity define" (Position 23 11) "infixr 7 `>>:`"+    , hoverTest "record" (Position 28 10) "infix 9 `>>::`"+    , hoverTest "wildcards1" (Position 30 5) "infixr 7 `>>:`"+    , hoverTest "wildcards2" (Position 30 5) "infix 9 `>>::`"+    , hoverTest "function" (Position 32 11) "infixl 1 `f`"+    , hoverTest "signature" (Position 35 2) "infixr 9 `>>>:`"+    , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`"+    , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`"+    -- Ensure that there is no one extra new line in import statement+    , expectFail $ hoverTest "import" (Position 2 18) "Control.Monad***"+    -- Known issue, See https://github.com/haskell/haskell-language-server/pull/2973/files#r916535742+    , expectFail $ hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"+    ]++hoverTest :: TestName -> Position -> T.Text -> TestTree+hoverTest = hoverTest' "Hover.hs"+hoverTestImport :: TestName -> Position -> T.Text -> TestTree+hoverTestImport = hoverTest' "HoverImport.hs"++hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree+hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do+    doc <- openDoc docName "haskell"+    waitForKickDone+    h <- getHover doc pos+    case h of+        Nothing -> liftIO $ assertFailure "No hover"+        Just (Hover contents _) -> case contents of+          InL (MarkupContent _ txt) -> do+              liftIO+                $ assertBool ("Failed to find `" <> T.unpack expected <> "` in hover message: " <> T.unpack txt)+                $ expected `T.isInfixOf` txt+          _ -> liftIO $ assertFailure "Unexpected content type"+    closeDoc doc++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-explicit-fixity-plugin" </> "test" </> "testdata"
+ plugins/hls-explicit-fixity-plugin/test/testdata/Hover.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE RecordWildCards #-}+module Hover where+import Control.Monad+import Data.Function (on)+import Control.Applicative ((<|>))+f1 = (++)+f2 = ($)+f3 = (.)+f4 = (+)+f5 = 1 - 2+f6 = (<>)+f7 = (>>=)+f8 = (>=>)+f9 = elem+f10 = on+f11 = (||)+f12 = mod+f13 = (**)+f14 = (^)+f15 = (<$)+f16 = seq+f17 = (<|>)++infixr 7 >>:+infix 9 >>::+data F = G+    { (>>:) :: Int -> Int -> Int+    , c :: Int+    , (>>::) :: Char+    }+f G{..} = undefined++infixl 1 `f`++infixr 9 >>>:+(>>>:) :: Int -> Int+(>>>:) x = 3++infixl 3 ~\:+(~\:) x y = 3
+ plugins/hls-explicit-fixity-plugin/test/testdata/HoverImport.hs view
@@ -0,0 +1,5 @@+module HoverImport where++import Hover++g = (>>>:)
+ plugins/hls-explicit-fixity-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE ViewPatterns       #-}+module Ide.Plugin.ExplicitImports+  ( descriptor+  , descriptorForModules+  , abbreviateImportTitle+  , Log(..)+  ) where++import           Control.DeepSeq+import           Control.Lens                         ((&), (?~))+import           Control.Monad.Error.Class            (MonadError (throwError))+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class            (lift)+import           Control.Monad.Trans.Except           (ExceptT)+import           Control.Monad.Trans.Maybe+import qualified Data.Aeson                           as A (ToJSON (toJSON))+import           Data.Aeson.Types                     (FromJSON)+import qualified Data.IntMap                          as IM (IntMap, elems,+                                                             fromList, (!?))+import           Data.IORef                           (readIORef)+import qualified Data.Map.Strict                      as Map+import           Data.Maybe                           (isNothing, mapMaybe)+import qualified Data.Set                             as S+import           Data.String                          (fromString)+import qualified Data.Text                            as T+import           Data.Traversable                     (for)+import qualified Data.Unique                          as U (hashUnique,+                                                            newUnique)+import           Development.IDE                      hiding (pluginHandlers,+                                                       pluginRules)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping+import qualified Development.IDE.Core.Shake           as Shake+import           Development.IDE.GHC.Compat           hiding ((<+>))+import           Development.IDE.Graph.Classes+import           GHC.Generics                         (Generic)+import           Ide.Plugin.Error                     (PluginError (..),+                                                       getNormalizedFilePathE,+                                                       handleMaybe)+import           Ide.Plugin.RangeMap                  (filterByRange)+import qualified Ide.Plugin.RangeMap                  as RM (RangeMap, fromList)+import           Ide.Plugin.Resolve+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server++-- This plugin is named explicit-imports for historical reasons. Besides+-- providing code actions and lenses to make imports explicit it also provides+-- code actions and lens to refine imports.++importCommandId :: CommandId+importCommandId = "ImportLensCommand"++data Log+  = LogShake Shake.Log+  | LogWAEResponseError ResponseError+  | forall a. (Pretty a) => LogResolve a+++instance Pretty Log where+  pretty = \case+    LogShake logMsg -> pretty logMsg+    LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> pretty rspErr+    LogResolve msg -> pretty msg++-- | The "main" function of a plugin+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder =+    -- (almost) no one wants to see an explicit import list for Prelude+    descriptorForModules recorder (/= moduleName pRELUDE)++descriptorForModules+    :: Recorder (WithPriority Log)+    -> (ModuleName -> Bool)+      -- ^ Predicate to select modules that will be annotated+    -> PluginId+    -> PluginDescriptor IdeState+descriptorForModules recorder modFilter plId =+  let resolveRecorder = cmapWithPrio LogResolve recorder+      codeActionHandlers = mkCodeActionHandlerWithResolve resolveRecorder (codeActionProvider recorder) (codeActionResolveProvider recorder)+  in (defaultPluginDescriptor plId "Provides a code action to make imports explicit")+    {+      -- This plugin provides a command handler+      pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)],+      -- This plugin defines a new rule+      pluginRules = minimalImportsRule recorder modFilter,+      pluginHandlers =+         -- This plugin provides code lenses+           mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder)+        <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder)+          -- This plugin provides code actions+        <> codeActionHandlers++    }++-- | The actual command handler+runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData+runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do+  wedit <- resolveWTextEdit ideState eird+  _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors+  return $ InR  Null+  where logErrors (Left re@(ResponseError{})) = do+          logWith recorder Error (LogWAEResponseError re)+          pure ()+        logErrors (Right _) = pure ()+runImportCommand _ _ _ rd = do+  throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for command handler:" <> show rd)+++-- | We provide two code lenses for imports. The first lens makes imports+-- explicit. For example, for the module below:+-- > import Data.List+-- > f = intercalate " " . sortBy length+-- the provider should produce one code lens associated to the import statement:+-- > import Data.List (intercalate, sortBy)+--+-- The second one allows us to import functions directly from the original+-- module. For example, for the following import+-- > import Random.ReExporting.Module (liftIO)+-- the provider should produce one code lens associated to the import statement:+-- > Refine imports to import Control.Monad.IO.Class (liftIO)+lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens+lensProvider _  state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do+    nfp <- getNormalizedFilePathE _uri+    (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp+    let lens = [ generateLens _uri newRange int+                | (range, int) <- forLens+                , Just newRange <- [toCurrentRange pm range]]+    pure $ InL lens+  where -- because these are non resolved lenses we only need the range and a+        -- unique id to later resolve them with. These are for both refine+        -- import lenses and for explicit import lenses.+        generateLens :: Uri  -> Range -> Int -> CodeLens+        generateLens uri range int =+          CodeLens { _data_ = Just $ A.toJSON $ ResolveOne uri int+                   , _range = range+                   , _command = Nothing }++lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeLensResolve+lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do+    nfp <- getNormalizedFilePathE uri+    (ImportActionsResult{forResolve}, _) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp+    target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid+    let updatedCodeLens = cl & L.command ?~  mkCommand plId target+    pure updatedCodeLens+  where mkCommand ::  PluginId -> ImportEdit -> Command+        mkCommand pId (ImportEdit{ieResType, ieText}) =+          let -- The only new thing we need to provide to resolve a lens is the+              -- title, as the unique Id is the same to resolve the lens title+              -- as it is to apply the lens through a command.+              -- The title is written differently depending on what type of lens+              -- it is.+              title ExplicitImport = abbreviateImportTitle ieText+              title RefineImport = "Refine imports to " <> T.intercalate ", " (T.lines ieText)+          in mkLspCommand pId importCommandId (title ieResType) (Just [A.toJSON rd])+lensResolveProvider _ _ _ _ _ rd = do+   throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for lens resolve handler: " <> show rd)++-- |For explicit imports: If there are any implicit imports, provide both one+-- code action per import to make that specific import explicit, and one code+-- action to turn them all into explicit imports. For refine imports: If there+-- are any reexported imports, provide both one code action per import to refine+-- that specific import, and one code action to refine all imports.+codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = do+    nfp <- getNormalizedFilePathE _uri+    (ImportActionsResult{forCodeActions}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp+    newRange <- toCurrentRangeE pm range+    let relevantCodeActions = filterByRange newRange forCodeActions+        allExplicit =+          [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ExplicitAll _uri)+          -- We should only provide this code action if there are any code+          -- of this type+          | any (\x -> iaResType x == ExplicitImport) relevantCodeActions]+        allRefine =+          [InR $ mkCodeAction "Refine all imports" (Just $ A.toJSON $ RefineAll _uri)+          -- We should only provide this code action if there are any code+          -- of this type+          | any (\x -> iaResType x == RefineImport) relevantCodeActions]+        -- The only thing different in making the two types of code actions, is+        -- the title. The actual resolve data type, ResolveOne is used by both+        -- of them+        toCodeAction uri (ImportAction _ int ExplicitImport) =+          mkCodeAction "Make this import explicit" (Just $ A.toJSON $ ResolveOne uri int)+        toCodeAction uri (ImportAction _  int RefineImport) =+          mkCodeAction "Refine this import" (Just $ A.toJSON $ ResolveOne uri int)+    pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit <> allRefine)+    where mkCodeAction title data_  =+            CodeAction+            { _title = title+            , _kind = Just CodeActionKind_QuickFix+            , _command = Nothing+            , _edit = Nothing+            , _diagnostics = Nothing+            , _isPreferred = Nothing+            , _disabled = Nothing+            , _data_ = data_}++codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeActionResolve+codeActionResolveProvider _ ideState _ ca _ rd = do+    wedit <- resolveWTextEdit ideState rd+    pure $ ca & L.edit ?~ wedit+--------------------------------------------------------------------------------++resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (LspT Config IO) WorkspaceEdit+-- Providing the edit for the command, or the resolve for the code action is+-- completely generic, as all we need is the unique id and the text edit.+resolveWTextEdit ideState (ResolveOne uri int) = do+  nfp <- getNormalizedFilePathE uri+  (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp+  iEdit <- handleMaybe PluginStaleResolve $ forResolve IM.!? int+  pure $ mkWorkspaceEdit uri [iEdit] pm+resolveWTextEdit ideState (ExplicitAll uri) = do+  nfp <- getNormalizedFilePathE uri+  (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp+  let edits = [ ie | ie@ImportEdit{ieResType = ExplicitImport} <- IM.elems forResolve]+  pure $ mkWorkspaceEdit uri edits pm+resolveWTextEdit ideState (RefineAll uri) = do+  nfp <- getNormalizedFilePathE uri+  (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp+  let edits = [ re | re@ImportEdit{ieResType = RefineImport} <- IM.elems forResolve]+  pure $ mkWorkspaceEdit uri edits pm+mkWorkspaceEdit :: Uri -> [ImportEdit] -> PositionMapping -> WorkspaceEdit+mkWorkspaceEdit uri edits pm =+      WorkspaceEdit {_changes = Just $ Map.fromList [(uri, mapMaybe toWEdit edits)]+                    , _documentChanges = Nothing+                    , _changeAnnotations = Nothing}+  where toWEdit ImportEdit{ieRange, ieText} =+          let newRange = toCurrentRange pm ieRange+          in (\r -> TextEdit r ieText) <$> newRange++data ImportActions = ImportActions+  deriving (Show, Generic, Eq, Ord)++instance Hashable ImportActions++instance NFData ImportActions++type instance RuleResult ImportActions = ImportActionsResult++data ResultType = ExplicitImport | RefineImport+  deriving Eq++data ImportActionsResult = ImportActionsResult+  { -- |For providing the code lenses we need to have a range, and a unique id+    -- that is later resolved to the new text for each import. It is stored in+    -- a list, because we always need to provide all the code lens in a file.+    forLens        :: [(Range, Int)]+    -- |For the code actions we have the same data as for the code lenses, but+    -- we store it in a RangeMap, because that allows us to filter on a specific+    -- range with better performance, and code actions are almost always only+    -- requested for a specific range+  , forCodeActions :: RM.RangeMap ImportAction+    -- |For resolve we have an intMap where for every previously provided unique id+    -- we provide a textEdit to allow our code actions or code lens to be resolved+  , forResolve     :: IM.IntMap ImportEdit }++-- |For resolving code lenses and code actions we need standard text edit stuff,+-- such as range and text, and then we need the result type, because we use this+-- for code lenses which need to create a appropriate title+data ImportEdit = ImportEdit { ieRange :: Range, ieText :: T.Text, ieResType :: ResultType}++-- |The necessary data for providing code actions: the range, a unique ID for+-- later resolving the action, and the type of action for giving a proper name.+data ImportAction = ImportAction { iaRange :: Range, iaUniqueId :: Int, iaResType :: ResultType}++instance Show ImportActionsResult where show _ = "<ImportActionsResult>"++instance NFData ImportActionsResult where rnf = rwhnf++data IAResolveData = ResolveOne+                      { uri      :: Uri+                      , importId :: Int }+                    | ExplicitAll+                      { uri :: Uri }+                    | RefineAll+                      { uri :: Uri }+                    deriving (Generic, Show, A.ToJSON, FromJSON)++exportedModuleStrings :: ParsedModule -> [String]+exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}}+  | Just export <- hsmodExports,+    exports <- unLoc export+    = map (T.unpack . printOutputable) exports+exportedModuleStrings _ = []++minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules ()+minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \ImportActions nfp -> runMaybeT $ do+  -- Get the typechecking artifacts from the module+  tmr <- MaybeT $ use TypeCheck nfp+  -- We also need a GHC session with all the dependencies+  hsc <- MaybeT $ use GhcSessionDeps nfp++  -- refine imports: 2 layer map ModuleName -> ModuleName -> [Avails] (exports)+  import2Map <- do+    -- first layer is from current(editing) module to its imports+    ImportMap currIm <- MaybeT $ use GetImportMap nfp+    for currIm $ \path -> do+      -- second layer is from the imports of first layer to their imports+      ImportMap importIm <- MaybeT $ use GetImportMap path+      for importIm $ \imp_path -> do+        imp_hir <- MaybeT $ use GetModIface imp_path+        return $ mi_exports $ hirModIface imp_hir++  -- Use the GHC api to extract the "minimal" imports+  locationImportWithMinimal <- MaybeT $ liftIO $ extractMinimalImports hsc tmr++  let minimalImportsResult =+        [ (range, (printOutputable minImport, ExplicitImport))+          | (location, impDecl, minImport) <- locationImportWithMinimal+          , not (isQualifiedImport impDecl)+          , not (isExplicitImport impDecl)+          , let L _ moduleName = ideclName impDecl+          , modFilter moduleName+          , let range = realSrcSpanToRange location]++      refineImportsResult =+        [ (range, (T.intercalate "\n"+                . map (printOutputable . constructImport origImport minImport)+                . Map.toList+                $ filteredInnerImports, RefineImport))+        -- for every minimal imports+        | (location, origImport, minImport@(ImportDecl{ideclName = L _ mn})) <- locationImportWithMinimal+        -- (almost) no one wants to see an refine import list for Prelude+        , mn /= moduleName pRELUDE+        -- we check for the inner imports+        , Just innerImports <- [Map.lookup mn import2Map]+        -- and only get those symbols used+        , Just filteredInnerImports <- [filterByImport minImport innerImports]+        -- if no symbols from this modules then don't need to generate new import+        , not $ null filteredInnerImports+        -- and then convert that to a Range+        , let range = realSrcSpanToRange location+        ]+  uniqueAndRangeAndText <- liftIO $ for (minimalImportsResult ++ refineImportsResult) $ \rt -> do+                                u <- U.hashUnique <$> U.newUnique+                                pure (u,  rt)+  let rangeAndUnique =  [ ImportAction r u rt | (u, (r, (_, rt))) <- uniqueAndRangeAndText ]+  pure ImportActionsResult+                      { forLens = (\ImportAction{..} -> (iaRange, iaUniqueId)) <$> rangeAndUnique+                      , forCodeActions = RM.fromList iaRange rangeAndUnique+                      , forResolve =  IM.fromList ((\(u, (r, (te, ty))) -> (u, ImportEdit r te ty)) <$> uniqueAndRangeAndText) }++--------------------------------------------------------------------------------++-- | Use the ghc api to extract a minimal, explicit set of imports for this module+extractMinimalImports ::+  HscEnvEq ->+  TcModuleResult ->+  IO (Maybe [(RealSrcSpan, ImportDecl GhcRn, ImportDecl GhcRn)])+extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do+  -- extract the original imports and the typechecking environment+  let tcEnv = tmrTypechecked+      (_, imports, _, _) = tmrRenamed+      ParsedModule {pm_parsed_source = L loc _} = tmrParsed+      emss = exportedModuleStrings tmrParsed+  Just srcSpan <- pure $ realSpan loc+  -- Don't make suggestions for modules which are also exported, the user probably doesn't want this!+  -- See https://github.com/haskell/haskell-language-server/issues/2079+  let notExportedImports = filter (notExported emss) imports++  -- GHC is secretly full of mutable state+  gblElts <- liftIO $ readIORef (tcg_used_gres tcEnv)++  -- call findImportUsage does exactly what we need+  -- GHC is full of treats like this+  let usage = findImportUsage notExportedImports gblElts+  (_, Just minimalImports) <- liftIO $+    initTcWithGbl (hscEnv hsc) tcEnv srcSpan $ getMinimalImports usage++  let minimalImportsMap =+        Map.fromList+          [ (realSrcSpanStart l, impDecl)+            | L (locA -> RealSrcSpan l _) impDecl <- minimalImports+          ]+      results =+          [ (location, imp, minImport)+          | L (locA -> RealSrcSpan location _) imp <- imports+          , Just minImport <- [Map.lookup (realSrcSpanStart location) minimalImportsMap]]+  -- return both the original imports and the computed minimal ones+  return results+  where+      notExported :: [String] -> LImportDecl GhcRn -> Bool+      notExported []  _ = True+      notExported exports (L _ ImportDecl{ideclName = L _ name}) =+          not $ any (\e -> ("module " ++ moduleNameString name) == e) exports++isExplicitImport :: ImportDecl GhcRn -> Bool+#if MIN_VERSION_ghc(9,5,0)+isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True+#else+isExplicitImport ImportDecl {ideclHiding = Just (False, _)}       = True+#endif+isExplicitImport _                                                = False++-- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things,+-- but at the moment I don't believe we know it.+-- 80 columns is traditional, but Haskellers tend to use longer lines (citation needed) and it's+-- probably not too bad if the lens is a *bit* longer than normal lines.+maxColumns :: Int+maxColumns = 120+++-- | The title of the command is ideally the minimal explicit import decl, but+-- we don't want to create a really massive code lens (and the decl can be extremely large!).+-- So we abbreviate it to fit a max column size, and indicate how many more items are in the list+-- after the abbreviation+abbreviateImportTitle :: T.Text -> T.Text+abbreviateImportTitle input =+  let+      -- For starters, we only want one line in the title+      oneLineText = T.unwords $ T.lines input+      -- Now, split at the max columns, leaving space for the summary text we're going to add+      -- (conservatively assuming we won't need to print a number larger than 100)+      (prefix, suffix) = T.splitAt (maxColumns - T.length (summaryText 100)) oneLineText+      -- We also want to truncate the last item so we get a "clean" break, rather than half way through+      -- something. The conditional here is just because 'breakOnEnd' doesn't give us quite the right thing+      -- if there are actually no commas.+      (actualPrefix, extraSuffix) = if T.count "," prefix > 0 then T.breakOnEnd "," prefix else (prefix, "")+      actualSuffix = extraSuffix <> suffix++      -- The number of additional items is the number of commas+1+      numAdditionalItems = T.count "," actualSuffix + 1+      -- We want to make text like this: import Foo (AImport, BImport, ... (30 items))+      -- We also want it to look sensible if we end up splitting in the module name itself,+      summaryText :: Int -> T.Text+      summaryText n = " ... (" <> fromString (show n) <> " items)"+      -- so we only add a trailing paren if we've split in the export list+      suffixText = summaryText numAdditionalItems <> if T.count "(" prefix > 0 then ")" else ""+      title =+          -- If the original text fits, just use it+          if T.length oneLineText <= maxColumns+          then oneLineText+          else actualPrefix <> suffixText+  in title++--------------------------------------------------------------------------------+++filterByImport :: ImportDecl GhcRn -> Map.Map ModuleName [AvailInfo] -> Maybe (Map.Map ModuleName [AvailInfo])+#if MIN_VERSION_ghc(9,5,0)+filterByImport (ImportDecl{ideclImportList = Just (_, L _ names)})+#else+filterByImport (ImportDecl{ideclHiding = Just (_, L _ names)})+#endif+  avails =+      -- if there is a function defined in the current module and is used+      -- i.e. if a function is not reexported but defined in current+      -- module then this import cannot be refined+  if importedNames `S.isSubsetOf` allFilteredAvailsNames+    then Just res+    else Nothing+  where importedNames = S.fromList $ map (ieName . unLoc) names+        res = flip Map.filter avails $ \a ->+                any (`S.member` importedNames)+                  $ concatMap+                      getAvailNames+                      a+        allFilteredAvailsNames = S.fromList+          $ concatMap getAvailNames+          $ mconcat+          $ Map.elems res+filterByImport _ _ = Nothing++constructImport :: ImportDecl GhcRn -> ImportDecl GhcRn -> (ModuleName, [AvailInfo]) -> ImportDecl GhcRn+#if MIN_VERSION_ghc(9,5,0)+constructImport ImportDecl{ideclQualified = qualified, ideclImportList = origHiding} imd@ImportDecl{ideclImportList = Just (hiding, L _ names)}+#else+constructImport ImportDecl{ideclQualified = qualified, ideclHiding = origHiding} imd@ImportDecl{ideclHiding = Just (hiding, L _ names)}+#endif+  (newModuleName, avails) = imd+    { ideclName = noLocA newModuleName+#if MIN_VERSION_ghc(9,5,0)+    , ideclImportList = if isNothing origHiding && qualified /= NotQualified+                        then Nothing+                        else Just (hiding, noLocA newNames)+#else+    , ideclHiding = if isNothing origHiding && qualified /= NotQualified+                        then Nothing+                        else Just (hiding, noLocA newNames)+#endif+    }+    where newNames = filter (\n -> any (n `containsAvail`) avails) names+          -- Check if a name is exposed by AvailInfo (the available information of a module)+          containsAvail :: LIE GhcRn -> AvailInfo -> Bool+          containsAvail name avail =+            any (\an -> printOutputable an == (printOutputable . ieName . unLoc $ name))+              $ getAvailNames avail++constructImport _ lim _ = lim++getAvailNames :: AvailInfo -> [Name]+getAvailNames =+#if MIN_VERSION_ghc(9,7,0)+  availNames+#else+  availNamesWithSelectors+#endif
+ plugins/hls-explicit-imports-plugin/test/Main.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE OverloadedLabels         #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE ViewPatterns             #-}+module Main+  ( main+  ) where++import           Control.Lens                  ((^.))+import           Data.Either.Extra+import           Data.Foldable                 (find)+import           Data.Row                      ((.+), (.==))+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Data.Traversable              (for)+import qualified Ide.Plugin.ExplicitImports    as ExplicitImports+import qualified Language.LSP.Protocol.Lens    as L+import           Language.LSP.Protocol.Message+import           System.FilePath               ((</>))+import           Test.Hls++explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log+explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports"++main :: IO ()+main = defaultTestRunner $ testGroup "import-actions"+  [testGroup+    "Refine Imports"+    [ codeActionGoldenTest "RefineWithOverride" 3 1+    , codeLensGoldenTest isRefineImports "RefineUsualCase" 1+    , codeLensGoldenTest isRefineImports "RefineQualified" 0+    , codeLensGoldenTest isRefineImports "RefineQualifiedExplicit" 0+    ],+  testGroup+    "Make imports explicit"+    [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0+    , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0+    , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0+    , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0+    , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0+    , codeActionBreakFile "ExplicitBreakFile" 4 0+    , codeActionStaleAction "ExplicitStaleAction" 4 0+    , testCase "No CodeAction when exported" $+      runSessionWithServer def explicitImportsPlugin testDataDir $ do+        doc <- openDoc "ExplicitExported.hs" "haskell"+        action <- getCodeActions doc (pointRange 3 0)+        liftIO $ action @?= []+    , testCase "No CodeLens when exported" $+      runSessionWithServer def explicitImportsPlugin testDataDir $ do+        doc <- openDoc "ExplicitExported.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ lenses @?= []+    , testGroup "Title abbreviation"+      [ testCase "not abbreviated" $+          let i = "import " <> T.replicate 70 "F" <> " (Athing, Bthing, Cthing)"+          in ExplicitImports.abbreviateImportTitle i @?= i+      , testCase "abbreviated in module name" $+          let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)"+              o = "import " <> T.replicate 97 "F" <> " ... (3 items)"+          in ExplicitImports.abbreviateImportTitle i @?= o+      , testCase "abbreviated in import list" $+          let i = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"+              o = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, ... (3 items))"+          in ExplicitImports.abbreviateImportTitle i @?= o+      -- This one breaks earlier in the same import item, but still splits the list in the same place+      , testCase "abbreviated in import list (slightly shorter module)" $+          let i = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"+              o = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, ... (3 items))"+          in ExplicitImports.abbreviateImportTitle i @?= o+      -- This one breaks later in the same import item, but still splits the list in the same place+      , testCase "abbreviated in import list (slightly longer module)" $+          let i = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"+              o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))"+          in ExplicitImports.abbreviateImportTitle i @?= o+      ]+    ]]++-- code action tests++codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree+codeActionAllGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do+  actions <- getCodeActions doc (pointRange l c)+  case find ((== Just "Make all imports explicit") . caTitle) actions of+    Just (InR x) -> executeCodeAction x+    _            -> liftIO $ assertFailure "Unable to find CodeAction"++codeActionBreakFile :: FilePath -> Int -> Int -> TestTree+codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do+  _ <- getCodeLenses doc+  changeDoc doc [edit]+  actions <- getCodeActions doc (pointRange l c)+  case find ((== Just "Make all imports explicit") . caTitle) actions of+    Just (InR x) -> executeCodeAction x+    _            -> liftIO $ assertFailure "Unable to find CodeAction"+  where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 29+                                                   .+ #rangeLength .== Nothing+                                                   .+ #text .== "x"++codeActionStaleAction :: FilePath -> Int -> Int -> TestTree+codeActionStaleAction fp l c = goldenWithImportActions " code action" fp codeActionResolveCaps $ \doc -> do+  _ <- waitForDiagnostics+  actions <- getCodeActions doc (pointRange l c)+  changeDoc doc [edit]+  _ <- waitForDiagnostics+  case find ((== Just "Make this import explicit") . caTitle) actions of+    Just (InR x) ->+      maybeResolveCodeAction x >>=+        \case Just _  -> liftIO $ assertFailure "Code action still valid"+              Nothing -> pure ()+    _            -> liftIO $ assertFailure "Unable to find CodeAction"+  where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0)+                                                   .+ #rangeLength .== Nothing+                                                   .+ #text .== "\ntesting = undefined"++codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree+codeActionAllResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do+  actions <- getCodeActions doc (pointRange l c)+  Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions+  resolved <- resolveCodeAction x+  executeCodeAction resolved++codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree+codeActionOnlyGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do+  actions <- getCodeActions doc (pointRange l c)+  case find ((== Just "Make this import explicit") . caTitle) actions of+    Just (InR x) -> executeCodeAction x+    _            -> liftIO $ assertFailure "Unable to find CodeAction"++codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree+codeActionOnlyResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do+  actions <- getCodeActions doc (pointRange l c)+  Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions+  resolved <- resolveCodeAction x+  executeCodeAction resolved++maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction)+maybeResolveCodeAction ca = do+  resolveResponse <- request SMethod_CodeActionResolve ca+  let resolved = resolveResponse ^. L.result+  pure $ eitherToMaybe resolved++caTitle :: (Command |? CodeAction) -> Maybe Text+caTitle (InR CodeAction {_title}) = Just _title+caTitle _                         = Nothing++-- code lens tests++codeLensGoldenTest :: (CodeLens -> Bool) -> FilePath -> Int -> TestTree+codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoResolveCaps $ \doc -> do+  codeLenses <- getCodeLenses doc+  resolvedCodeLenses <- for codeLenses resolveCodeLens+  (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i)+  executeCmd c++notRefineImports :: CodeLens -> Bool+notRefineImports (CodeLens _ (Just (Command text _ _)) _)+  | "Refine imports to" `T.isPrefixOf` text = False+notRefineImports _ = True++-- Execute command and wait for result+executeCmd :: Command -> Session ()+executeCmd cmd = do+    executeCommand cmd+    _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+    -- liftIO $ print _resp+    return ()++-- helpers++goldenWithImportActions :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithImportActions title fp caps = goldenWithHaskellAndCaps def caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs"++testDataDir :: String+testDataDir = "plugins" </> "hls-explicit-imports-plugin" </> "test" </> "testdata"++pointRange :: Int -> Int -> Range+pointRange+  (subtract 1 -> fromIntegral -> line)+  (subtract 1 -> fromIntegral -> col) =+    Range (Position line col) (Position line $ col + 1)++-------------------------------------------------------------------------------+-- code action tests++codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree+codeActionGoldenTest fp l c = goldenWithImportActions "" fp codeActionNoResolveCaps $ \doc -> do+  actions <- getCodeActions doc (pointRange l c)+  case find ((== Just "Refine all imports") . caTitle) actions of+    Just (InR x) -> executeCodeAction x+    _            -> liftIO $ assertFailure "Unable to find CodeAction"++isRefineImports :: CodeLens -> Bool+isRefineImports (CodeLens _ (Just (Command txt _ _)) _)+  | "Refine imports to" `T.isInfixOf` txt = True+isRefineImports _ = False
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitA.hs view
@@ -0,0 +1,7 @@+module ExplicitA where++a1 :: String+a1 = "a1"++a2 :: String+a2 = "a2"
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitB.hs view
@@ -0,0 +1,7 @@+module ExplicitB where++b1 :: String+b1 = "b1"++b2 :: String+b2 = "b2"
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.expected.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}+module ExplicitBreakFile whexe++import ExplicitA ( a1 )++main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}+module ExplicitBreakFile where++import ExplicitA++main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitExported.hs view
@@ -0,0 +1,6 @@+module ExplicitExported (module ExplicitA) where++import ExplicitA++main :: IO ()+main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.expected.hs view
@@ -0,0 +1,7 @@+module ExplicitOnlyThis where++import ExplicitA ( a1 )+import ExplicitB++main :: IO ()+main = putStrLn $ "hello " ++ a1 ++ b1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.hs view
@@ -0,0 +1,7 @@+module ExplicitOnlyThis where++import ExplicitA+import ExplicitB++main :: IO ()+main = putStrLn $ "hello " ++ a1 ++ b1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.expected.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wall #-}+module ExplicitStaleAction where++import ExplicitA++main = putStrLn $ "hello " ++ a1++testing = undefined
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}+module ExplicitStaleAction where++import ExplicitA++main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.expected.hs view
@@ -0,0 +1,6 @@+module ExplicitUsualCase where++import ExplicitA ( a1 )++main :: IO ()+main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.hs view
@@ -0,0 +1,6 @@+module ExplicitUsualCase where++import ExplicitA++main :: IO ()+main = putStrLn $ "hello " ++ a1
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineA.hs view
@@ -0,0 +1,7 @@+module RefineA +  ( module RefineB+  , module RefineC+  ) where++import RefineB+import RefineC
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineB.hs view
@@ -0,0 +1,7 @@+module RefineB where ++b1 :: String+b1 = "b1"++b2 :: String+b2 = "b2"
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineC.hs view
@@ -0,0 +1,4 @@+module RefineC where++c1 :: String+c1 = "c1"
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineD.hs view
@@ -0,0 +1,7 @@+module RefineD (module RefineE, module RefineD) where++import RefineE hiding (e1)+import qualified RefineE++e1 :: String +e1 = RefineE.e1 <> " but overrided"
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineE.hs view
@@ -0,0 +1,7 @@+module RefineE where++e1 :: String+e1 = "e1"++e2 :: String+e2 = "e2"
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineF.hs view
@@ -0,0 +1,7 @@+module RefineF (module RefineF, module RefineG) where++import RefineG++f1 :: String +f1 = "f1"+
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineG.hs view
@@ -0,0 +1,4 @@+module RefineG where++g1 :: String +g1 = "g1"
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.expected.hs view
@@ -0,0 +1,11 @@+module Main where++import qualified RefineB as RA+import qualified RefineC as RA+import RefineD+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [RA.b1, RA.c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified RefineA as RA+import RefineD+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [RA.b1, RA.c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.expected.hs view
@@ -0,0 +1,11 @@+module Main where++import qualified RefineB as RA ( b1 )+import qualified RefineC as RA ( c1 )+import RefineD+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [RA.b1, RA.c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified RefineA as RA (b1, c1)+import RefineD+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [RA.b1, RA.c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.expected.hs view
@@ -0,0 +1,10 @@+module Main where++import RefineA+import RefineE ( e2 )+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [b1, c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.hs view
@@ -0,0 +1,10 @@+module Main where++import RefineA+import RefineD+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [b1, c1, e2]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.expected.hs view
@@ -0,0 +1,12 @@+module Main where++import RefineB ( b1 )+import RefineC ( c1 )+import RefineD+import RefineF+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [b1, c1, e1, f1, g1]
+ plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.hs view
@@ -0,0 +1,11 @@+module Main where++import RefineA+import RefineD+import RefineF+import Data.List (intercalate)++main :: IO ()+main = putStrLn +     $ "hello " +    <> intercalate ", " [b1, c1, e1, f1, g1]
+ plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,20 @@+cradle:+  direct:+    arguments:+    - ExplicitOnlyThis.hs+    - ExplicitStaleAction.hs+    - ExplicitUsualCase.hs+    - ExplicitExported.hs+    - ExplicitA.hs+    - ExplicitB.hs+    - RefineUsualCase.hs+    - RefineQualified.hs+    - RefineQualifiedExplicit.hs+    - RefineWithOverride.hs+    - RefineA.hs+    - RefineB.hs+    - RefineC.hs+    - RefineD.hs+    - RefineE.hs+    - RefineF.hs+    - RefineG.hs
+ plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE ViewPatterns      #-}++module Ide.Plugin.ExplicitFields+  ( descriptor+  , Log+  ) where++import           Control.Lens                     ((&), (?~), (^.))+import           Control.Monad.IO.Class           (MonadIO (liftIO))+import           Control.Monad.Trans.Maybe+import           Data.Aeson                       (toJSON)+import           Data.Generics                    (GenericQ, everything,+                                                   everythingBut, extQ, mkQ)+import qualified Data.IntMap.Strict               as IntMap+import qualified Data.Map                         as Map+import           Data.Maybe                       (fromMaybe, isJust,+                                                   maybeToList)+import           Data.Text                        (Text)+import           Data.Unique                      (hashUnique, newUnique)++import           Control.Monad                    (replicateM)+import           Development.IDE                  (IdeState, Pretty (..), Range,+                                                   Recorder (..), Rules,+                                                   WithPriority (..),+                                                   defineNoDiagnostics,+                                                   realSrcSpanToRange, viaShow)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.RuleTypes   (TcModuleResult (..),+                                                   TypeCheck (..))+import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.GHC.Compat       (HsConDetails (RecCon),+                                                   HsExpansion (HsExpanded),+                                                   HsExpr (XExpr),+                                                   HsRecFields (..), LPat,+                                                   Outputable, getLoc,+                                                   recDotDot, unLoc)+import           Development.IDE.GHC.Compat.Core  (Extension (NamedFieldPuns),+                                                   GhcPass,+                                                   HsExpr (RecordCon, rcon_flds),+                                                   HsRecField, LHsExpr,+                                                   LocatedA, Name, Pass (..),+                                                   Pat (..), RealSrcSpan,+                                                   UniqFM, conPatDetails,+                                                   emptyUFM, hfbPun, hfbRHS,+                                                   hs_valds, lookupUFM,+                                                   mapConPatDetail, mapLoc,+                                                   pattern RealSrcSpan,+                                                   plusUFM_C, unitUFM)+import           Development.IDE.GHC.Util         (getExtensions,+                                                   printOutputable)+import           Development.IDE.Graph            (RuleResult)+import           Development.IDE.Graph.Classes    (Hashable, NFData)+import           Development.IDE.Spans.Pragmas    (NextPragmaInfo (..),+                                                   getFirstPragma,+                                                   insertNewPragma)+import           GHC.Generics                     (Generic)+import           Ide.Logger                       (Priority (..), cmapWithPrio,+                                                   logWith, (<+>))+import           Ide.Plugin.Error                 (PluginError (PluginInternalError, PluginStaleResolve),+                                                   getNormalizedFilePathE,+                                                   handleMaybe)+import           Ide.Plugin.RangeMap              (RangeMap)+import qualified Ide.Plugin.RangeMap              as RangeMap+import           Ide.Plugin.Resolve               (mkCodeActionWithResolveAndCommand)+import           Ide.Types                        (PluginDescriptor (..),+                                                   PluginId (..),+                                                   PluginMethodHandler,+                                                   ResolveFunction,+                                                   defaultPluginDescriptor)+import qualified Language.LSP.Protocol.Lens       as L+import           Language.LSP.Protocol.Message    (Method (..))+import           Language.LSP.Protocol.Types      (CodeAction (..),+                                                   CodeActionKind (CodeActionKind_RefactorRewrite),+                                                   CodeActionParams (..),+                                                   Command, TextEdit (..),+                                                   WorkspaceEdit (WorkspaceEdit),+                                                   type (|?) (InL, InR))+++data Log+  = LogShake Shake.Log+  | LogCollectedRecords [RecordInfo]+  | LogRenderedRecords [TextEdit]+  | forall a. (Pretty a) => LogResolve a+++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog+    LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs+    LogRenderedRecords recs -> "Rendered records:" <+> viaShow recs+    LogResolve msg -> pretty msg++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  let resolveRecorder = cmapWithPrio LogResolve recorder+      (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider+  in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit")+  { pluginHandlers = caHandlers+  , pluginCommands = carCommands+  , pluginRules = collectRecordsRule recorder *> collectNamesRule+  }++codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do+  nfp <- getNormalizedFilePathE (docId ^. L.uri)+  CRR {crCodeActions, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp+  -- All we need to build a code action is the list of extensions, and a int to+  -- allow us to resolve it later.+  let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions)+  pure $ InL actions+  where+    mkCodeAction ::  [Extension] ->  Int -> Command |? CodeAction+    mkCodeAction  exts uid = InR CodeAction+      { _title = "Expand record wildcard"+                  <> if NamedFieldPuns `elem` exts+                    then mempty+                    else " (needs extension: NamedFieldPuns)"+      , _kind = Just CodeActionKind_RefactorRewrite+      , _diagnostics = Nothing+      , _isPreferred = Nothing+      , _disabled = Nothing+      , _edit = Nothing+      , _command = Nothing+      , _data_ = Just $ toJSON uid+      }++codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve+codeActionResolveProvider ideState pId ca uri uid = do+  nfp <- getNormalizedFilePathE uri+  pragma <- getFirstPragma pId ideState nfp+  CRR {crCodeActionResolve, nameMap, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp+  -- If we are unable to find the unique id in our IntMap of records, it means+  -- that this resolve is stale.+  record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve+  -- We should never fail to render+  rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record+  let edits = [rendered]+              <> maybeToList (pragmaEdit enabledExtensions pragma)+  pure $ ca & L.edit ?~ mkWorkspaceEdit edits+  where+    mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit+    mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing+    pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit+    pragmaEdit exts pragma = if NamedFieldPuns `elem` exts+                      then Nothing+                      else Just $ insertNewPragma pragma NamedFieldPuns++collectRecordsRule :: Recorder (WithPriority Log) -> Rules ()+collectRecordsRule recorder =+  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do+  tmr <- useMT TypeCheck nfp+  (CNR nameMap) <- useMT CollectNames nfp+  let recs = getRecords tmr+  logWith recorder Debug (LogCollectedRecords recs)+  -- We want a list of unique numbers to link our the original code action we+  -- give out, with the actual record info that we resolve it to.+  uniques <- liftIO $ replicateM (length recs) (hashUnique <$> newUnique)+  let recsWithUniques = zip uniques recs+      -- For creating the code actions, a RangeMap of unique ids+      crCodeActions = RangeMap.fromList' (toRangeAndUnique <$> recsWithUniques)+      -- For resolving the code actions, a IntMap which links the unique id to+      -- the relevant record info.+      crCodeActionResolve = IntMap.fromList recsWithUniques+      enabledExtensions = getEnabledExtensions tmr+  pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions}+  where+    getEnabledExtensions :: TcModuleResult -> [Extension]+    getEnabledExtensions =  getExtensions . tmrParsed+    toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid)++getRecords :: TcModuleResult -> [RecordInfo]+getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =+  collectRecords valBinds++collectNamesRule :: Rules ()+collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do+  tmr <- useMT TypeCheck nfp+  pure (CNR (getNames tmr))++-- | Collects all 'Name's of a given source file, to be used+-- in the variable usage analysis.+getNames :: TcModuleResult -> UniqFM Name [Name]+getNames (tmrRenamed -> (group,_,_,_)) = collectNames group++data CollectRecords = CollectRecords+                    deriving (Eq, Show, Generic)++instance Hashable CollectRecords+instance NFData CollectRecords++-- |The result of our map, this record includes everything we need to provide+-- code actions and resolve them later+data CollectRecordsResult = CRR+  { -- |For providing the code action we need the unique id (Int) in a RangeMap+    crCodeActions       :: RangeMap Int+    -- |For resolving the code action we need to link the unique id we+    -- previously gave out with the record info that we use to make the edit+    -- with.+  , crCodeActionResolve :: IntMap.IntMap RecordInfo+    -- |The name map allows us to prune unused record fields (some of the time)+  , nameMap             :: UniqFM Name [Name]+    -- |We need to make sure NamedFieldPuns is enabled, if it's not we need to+    -- add that to the text edit. (In addition we use it in creating the code+    -- action title)+  , enabledExtensions   :: [Extension]+  }+  deriving (Generic)++instance NFData CollectRecordsResult+instance NFData RecordInfo++instance Show CollectRecordsResult where+  show _ = "<CollectRecordsResult>"++type instance RuleResult CollectRecords = CollectRecordsResult++data CollectNames = CollectNames+                  deriving (Eq, Show, Generic)++instance Hashable CollectNames+instance NFData CollectNames++data CollectNamesResult = CNR (UniqFM Name [Name])+  deriving (Generic)++instance NFData CollectNamesResult++instance Show CollectNamesResult where+  show _ = "<CollectNamesResult>"++type instance RuleResult CollectNames = CollectNamesResult++data RecordInfo+  = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed))+  | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed))+  deriving (Generic)++instance Pretty RecordInfo where+  pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p)+  pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)++recordInfoToRange :: RecordInfo -> Range+recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss+recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss++renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit+renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat+renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr++-- | Checks if a 'Name' is referenced in the given map of names. The+-- 'hasNonBindingOcc' check is necessary in order to make sure that only the+-- references at the use-sites are considered (i.e. the binding occurence+-- is excluded). For more information regarding the structure of the map,+-- refer to the documentation of 'collectNames'.+referencedIn :: Name -> UniqFM Name [Name] -> Bool+referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name+  where+    hasNonBindingOcc :: [Name] -> Bool+    hasNonBindingOcc = (> 1) . length++-- Default to leaving the element in if somehow a name can't be extracted (i.e.+-- `getName` returns `Nothing`).+filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a]+filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x))++preprocessRecordPat+  :: p ~ GhcPass 'Renamed+  => UniqFM Name [Name]+  -> HsRecFields p (LPat p)+  -> HsRecFields p (LPat p)+preprocessRecordPat = preprocessRecord (getFieldName . unLoc)+  where+    getFieldName x = case unLoc (hfbRHS x) of+      VarPat _ x' -> Just $ unLoc x'+      _           -> Nothing++-- No need to check the name usage in the record construction case+preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg+preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM++-- This function does two things:+-- 1) Tweak the AST type so that the pretty-printed record is in the+--    expanded form+-- 2) Determine the unused record fields so that they are filtered out+--    of the final output+--+-- Regarding first point:+-- We make use of the `Outputable` instances on AST types to pretty-print+-- the renamed and expanded records back into source form, to be substituted+-- with the original record later. However, `Outputable` instance of+-- `HsRecFields` does smart things to print the records that originally had+-- wildcards in their original form (i.e. with dots, without field names),+-- even after the wildcard is removed by the renamer pass. This is undesirable,+-- as we want to print the records in their fully expanded form.+-- Here `rec_dotdot` is set to `Nothing` so that fields are printed without+-- such post-processing.+preprocessRecord+  :: p ~ GhcPass c+  => (LocatedA (HsRecField p arg) -> Maybe Name)+  -> UniqFM Name [Name]+  -> HsRecFields p arg+  -> HsRecFields p arg+preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' }+  where+    no_pun_count = fromMaybe (length (rec_flds flds)) (recDotDot flds)+    -- Field binds of the explicit form (e.g. `{ a = a' }`) should be+    -- left as is, hence the split.+    (no_puns, puns) = splitAt no_pun_count (rec_flds flds)+    -- `hsRecPun` is set to `True` in order to pretty-print the fields as field+    -- puns (since there is similar mechanism in the `Outputable` instance as+    -- explained above).+    puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns+    -- Unused fields are filtered out so that they don't end up in the expanded+    -- form.+    punsUsed = filterReferenced getName names puns'+    rec_flds' = no_puns <> punsUsed++showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text+showRecordPat names = fmap printOutputable . mapConPatDetail (\case+  RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)+  _           -> Nothing)++showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text+showRecordCon expr@(RecordCon _ _ flds) =+  Just $ printOutputable $+    expr { rcon_flds = preprocessRecordCon flds }+showRecordCon _ = Nothing++collectRecords :: GenericQ [RecordInfo]+collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)++-- | Collect 'Name's into a map, indexed by the names' unique identifiers.+-- The 'Eq' instance of 'Name's makes use of their unique identifiers, hence+-- any 'Name' referring to the same entity is considered equal. In effect,+-- each individual list of names contains the binding occurrence, along with+-- all the occurrences at the use-sites (if there are any).+--+-- @UniqFM Name [Name]@ is morally the same as @Map Unique [Name]@.+-- Using 'UniqFM' gains us a bit of performance (in theory) since it+-- internally uses 'IntMap'. More information regarding 'UniqFM' can be found in+-- the GHC source.+collectNames :: GenericQ (UniqFM Name [Name])+collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x]))++getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)+-- When we stumble upon an occurrence of HsExpanded, we only want to follow a+-- single branch. We do this here, by explicitly returning occurrences from+-- traversing the original branch, and returning True, which keeps syb from+-- implicitly continuing to traverse. In addition, we have to return a list,+-- because there is a possibility that there were be more than one result per+-- branch++getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True)+getRecCons e@(unLoc -> RecordCon _ _ flds)+  | isJust (rec_dotdot flds) = (mkRecInfo e, False)+  where+    mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo]+    mkRecInfo expr =+      [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]]+getRecCons _ = ([], False)++getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)+getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))+  | isJust (rec_dotdot flds) = (mkRecInfo conPat, False)+  where+    mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo]+    mkRecInfo pat =+      [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]+getRecPatterns _ = ([], False)++
+ plugins/hls-explicit-record-fields-plugin/test/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}++module Main ( main ) where++import           Data.Either               (rights)+import qualified Data.Text                 as T+import qualified Ide.Plugin.ExplicitFields as ExplicitFields+import           System.FilePath           ((<.>), (</>))+import           Test.Hls++main :: IO ()+main = defaultTestRunner test++plugin :: PluginTestDescriptor ExplicitFields.Log+plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields"++test :: TestTree+test = testGroup "explicit-fields"+  [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20+  , mkTest "Unused" "Unused" 12 10 12 20+  , mkTest "Unused2" "Unused2" 12 10 12 20+  , mkTest "WithPun" "WithPun" 13 10 13 25+  , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32+  , mkTest "Mixed" "Mixed" 14 10 14 37+  , mkTest "Construction" "Construction" 16 5 16 15+  , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20+  , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22+  , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52+  , mkTestNoAction "Puns" "Puns" 12 10 12 31+  , mkTestNoAction "Infix" "Infix" 11 11 11 31+  , mkTestNoAction "Prefix" "Prefix" 10 11 10 28+  ]++mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree+mkTestNoAction title fp x1 y1 x2 y2 =+  testCase title $+    runSessionWithServer def plugin (testDataDir </> "noop") $ do+      doc <- openDoc (fp <.> "hs") "haskell"+      actions <- getExplicitFieldsActions doc x1 y1 x2 y2+      liftIO $ actions @?= []++mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree+mkTestWithCount cnt title fp x1 y1 x2 y2 =+  goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do+    acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2+    liftIO $ length acts @?= cnt+    executeCodeAction act++mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree+mkTest = mkTestWithCount 1++getExplicitFieldsActions+  :: TextDocumentIdentifier+  -> UInt -> UInt -> UInt -> UInt+  -> Session [CodeAction]+getExplicitFieldsActions doc x1 y1 x2 y2 =+  findExplicitFieldsAction <$> getAndResolveCodeActions doc range+  where+    range = Range (Position x1 y1) (Position x2 y2)++findExplicitFieldsAction :: [a |? CodeAction] -> [CodeAction]+findExplicitFieldsAction = filter isExplicitFieldsCodeAction . rights . map toEither++isExplicitFieldsCodeAction :: CodeAction -> Bool+isExplicitFieldsCodeAction CodeAction {_title} =+  "Expand record wildcard" `T.isPrefixOf` _title++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-explicit-record-fields-plugin" </> "test" </> "testdata"
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Construction where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: () -> MyRec+convertMe _ =+  let foo = 3+      bar = 5+      baz = 'a'+  in MyRec {foo, bar, baz}
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}++module Construction where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: () -> MyRec+convertMe _ =+  let foo = 3+      bar = 5+      baz = 'a'+  in MyRec {..}
+ plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}++module HsExpanded1 where+import Prelude++ifThenElse :: Int -> Int -> Int ->  Int+ifThenElse x y z = x + y + z++data MyRec = MyRec+  { foo :: Int }++myRecExample = MyRec 5++convertMe :: Int+convertMe =+  if (let MyRec {foo} = myRecExample+      in foo) then 1 else 2
+ plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}++module HsExpanded1 where+import Prelude++ifThenElse :: Int -> Int -> Int ->  Int+ifThenElse x y z = x + y + z++data MyRec = MyRec+  { foo :: Int }++myRecExample = MyRec 5++convertMe :: Int+convertMe =+  if (let MyRec {..} = myRecExample+      in foo) then 1 else 2
+ plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}++module HsExpanded2 where+import Prelude++ifThenElse :: Int -> Int -> Int ->  Int+ifThenElse x y z = x + y + z++data MyRec = MyRec+  { foo :: Int }++data YourRec = YourRec+  { bar :: Int }++myRecExample = MyRec 5++yourRecExample = YourRec 3++convertMe :: Int+convertMe =+  if (let MyRec {..} = myRecExample+          YourRec {bar} = yourRecExample+      in bar) then 1 else 2
+ plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}++module HsExpanded2 where+import Prelude++ifThenElse :: Int -> Int -> Int ->  Int+ifThenElse x y z = x + y + z++data MyRec = MyRec+  { foo :: Int }++data YourRec = YourRec+  { bar :: Int }++myRecExample = MyRec 5++yourRecExample = YourRec 3++convertMe :: Int+convertMe =+  if (let MyRec {..} = myRecExample+          YourRec {..} = yourRecExample+      in bar) then 1 else 2
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Mixed where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  , quux :: Double+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar = bar', baz} = show foo ++ show bar' ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Mixed where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  , quux :: Double+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar = bar', ..} = show foo ++ show bar' ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Unused where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar} = show foo ++ show bar
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}++module Unused where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {..} = show foo ++ show bar
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Unused2 where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar} = let baz = "baz" in show foo ++ show bar ++ baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}++module Unused2 where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {..} = let baz = "baz" in show foo ++ show bar ++ baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module WildcardOnly where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}++module WildcardOnly where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {..} = show foo ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module WithExplicitBind where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo = foo', bar, baz} = show foo' ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}++module WithExplicitBind where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo = foo', ..} = show foo' ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module WithPun where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module WithPun where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, ..} = show foo ++ show bar ++ show baz
+ plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: []}}
+ plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE Haskell2010 #-}++module ExplicitBinds where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo = foo', bar = bar', baz = baz'} = show foo' ++ show bar' ++ show baz'
+ plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Haskell2010 #-}++module Infix where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  }++convertMe :: MyRec -> String+convertMe (foo' `MyRec` bar') = show foo' ++ show bar'
+ plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Haskell2010 #-}++module Prefix where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  }++convertMe :: MyRec -> String+convertMe (foo' `MyRec` bar') = show foo' ++ show bar'
+ plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE NamedFieldPuns #-}++module Puns where++data MyRec = MyRec+  { foo :: Int+  , bar :: Int+  , baz :: Char+  }++convertMe :: MyRec -> String+convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz
+ plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Floskell+  ( descriptor+  , provider+  ) where++import           Control.Monad.Except        (throwError)+import           Control.Monad.IO.Class+import qualified Data.Text                   as T+import qualified Data.Text.Lazy              as TL+import           Development.IDE             hiding (pluginHandlers)+import           Floskell+import           Ide.Plugin.Error+import           Ide.PluginUtils+import           Ide.Types+import           Language.LSP.Protocol.Types++-- ---------------------------------------------------------------------++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId desc)+  { pluginHandlers = mkFormattingHandlers provider+  }+  where+    desc = "Provides formatting of Haskell files via floskell. Built with floskell-" <> VERSION_floskell++-- ---------------------------------------------------------------------++-- | Format provider of Floskell.+-- Formats the given source in either a given Range or the whole Document.+-- If the provider fails an error is returned that can be displayed to the user.+provider :: FormattingHandler IdeState+provider _ideState _token typ contents fp _ = do+    let file = fromNormalizedFilePath fp+    config <- liftIO $ findConfigOrDefault file+    let (range, selectedContents) = case typ of+          FormatText    -> (fullRange contents, contents)+          FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents)+        result = reformat config (Just file) $ TL.fromStrict selectedContents+    case result of+      Left  err -> throwError $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err+      Right new -> pure $ InL [TextEdit range $ TL.toStrict new]++-- | Find Floskell Config, user and system wide or provides a default style.+-- Every directory of the filepath will be searched to find a user configuration.+-- Also looks into places such as XDG_CONFIG_DIRECTORY<https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html>.+-- This function may not throw an exception and returns a default config.+findConfigOrDefault :: FilePath -> IO AppConfig+findConfigOrDefault file = do+  mbConf <- findAppConfigIn file+  case mbConf of+    Just confFile -> readAppConfig confFile+    Nothing ->+      let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles)+      in pure $ defaultAppConfig { appStyle = gibiansky }++-- ---------------------------------------------------------------------
+ plugins/hls-floskell-plugin/test/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+module Main+  ( main+  ) where++import qualified Ide.Plugin.Floskell as Floskell+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++floskellPlugin :: PluginTestDescriptor ()+floskellPlugin = mkPluginTestDescriptor' Floskell.descriptor "floskell"++tests :: TestTree+tests = testGroup "floskell"+  [ goldenWithFloskell "formats a document" "Floskell" "formatted_document" $ \doc -> do+      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)++  , goldenWithFloskell "formats a range" "Floskell" "formatted_range" $ \doc -> do+      let range = Range (Position 1 0) (Position 4 22)+      formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range+  ]++goldenWithFloskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithFloskell title path desc = goldenWithHaskellDocFormatter def floskellPlugin "floskell" def title testDataDir path desc "hs"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-floskell-plugin" </> "test" </> "testdata"
+ plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_document.hs view
@@ -0,0 +1,17 @@+module Floskell where++import           Data.List+import           Prelude+import           Data.Int++foo :: Int -> Int+foo 3 = 2+foo x = x++bar :: String -> IO String+bar s = do+  x <- return "hello"+  return "asdf"++data Baz = Baz { a :: Int, b :: String }+
+ plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_range.hs view
@@ -0,0 +1,14 @@+module    Floskell where+import           Data.List+import           Prelude+import           Data.Int+foo   :: Int ->  Int+foo  3 = 2+foo    x  = x+bar   :: String ->   IO String+bar s =  do+      x <- return "hello"+      return "asdf"++data Baz = Baz { a :: Int, b :: String }+
+ plugins/hls-floskell-plugin/test/testdata/Floskell.hs view
@@ -0,0 +1,15 @@+module    Floskell where+import Data.List++import Prelude+import Data.Int+foo   :: Int ->  Int+foo  3 = 2+foo    x  = x+bar   :: String ->   IO String+bar s =  do+      x <- return "hello"+      return "asdf"++data Baz = Baz { a :: Int, b :: String }+
+ plugins/hls-floskell-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Ide.Plugin.Fourmolu (+    descriptor,+    provider,+    LogEvent,+) where++import           Control.Exception+import           Control.Lens                    ((^.))+import           Control.Monad                   (guard)+import           Control.Monad.Error.Class       (MonadError (throwError))+import           Control.Monad.IO.Class          (MonadIO (liftIO))+import           Control.Monad.Trans.Class       (MonadTrans (lift))+import           Control.Monad.Trans.Except      (ExceptT (..), runExceptT)+import           Data.Bifunctor                  (bimap)+import           Data.List                       (intercalate)+import           Data.Maybe                      (catMaybes)+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Development.IDE                 hiding (pluginHandlers)+import           Development.IDE.GHC.Compat      as Compat hiding (Cpp, Warning,+                                                            hang, vcat)+import qualified Development.IDE.GHC.Compat.Util as S+import           GHC.LanguageExtensions.Type     (Extension (Cpp))+import           Ide.Plugin.Error+import           Ide.Plugin.Properties+import           Ide.PluginUtils                 (makeDiffTextEdit)+import           Ide.Types+import           Language.LSP.Protocol.Lens      (HasTabSize (tabSize))+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server             hiding (defaultConfig)+import           Ormolu+import           Ormolu.Config+import           System.Exit+import           System.FilePath+import           System.Process.Run              (cwd, proc)+import           System.Process.Text             (readCreateProcessWithExitCode)+import           Text.Read                       (readMaybe)++descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+    (defaultPluginDescriptor plId desc)+        { pluginHandlers = mkFormattingHandlers $ provider recorder plId+        , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties}+        }+  where+    desc = "Provides formatting of Haskell files via fourmolu. Built with fourmolu-" <> VERSION_fourmolu++properties :: Properties '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString]+properties =+    emptyProperties+        & defineStringProperty+            #path+            "Set path to executable (for \"external\" mode)."+            "fourmolu"+        & defineBooleanProperty+            #external+            "Call out to an external \"fourmolu\" executable, rather than using the bundled library."+            False++provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState+provider recorder plId ideState token typ contents fp fo = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do+    fileOpts <-+        maybe [] (convertDynFlags . hsc_dflags . hscEnv)+            <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp)+    useCLI <- liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #external plId properties+    fourmoluExePath <- fmap T.unpack $ liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #path plId properties+    if useCLI+        then ExceptT . liftIO $+                handle @IOException (pure . Left . PluginInternalError . T.pack . show) $+                    runExceptT (cliHandler fourmoluExePath fileOpts)+        else do+            logWith recorder Debug $ LogCompiledInVersion VERSION_fourmolu+            FourmoluConfig{..} <-+                liftIO (loadConfigFile fp') >>= \case+                    ConfigLoaded file opts -> do+                        logWith recorder Info $ ConfigPath file+                        pure opts+                    ConfigNotFound searchDirs -> do+                        logWith recorder Info $ NoConfigPath searchDirs+                        pure emptyConfig+                    ConfigParseError f err -> do+                        lift $ sendNotification SMethod_WindowShowMessage $+                            ShowMessageParams+                                { _type_ = MessageType_Error+                                , _message = errorMessage+                                }+                        throwError $ PluginInternalError errorMessage+                      where+                        errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (show err)++            let config =+#if MIN_VERSION_fourmolu(0,13,0)+                    refineConfig ModuleSource Nothing Nothing Nothing+#endif+                    defaultConfig+                        { cfgDynOptions = map DynOption fileOpts+                        , cfgFixityOverrides = cfgFileFixities+                        , cfgRegion = region+                        , cfgDebug = False+                        , cfgPrinterOpts = resolvePrinterOpts [lspPrinterOpts, cfgFilePrinterOpts]+                        }+            ExceptT . liftIO $+                bimap (PluginInternalError . T.pack . show) (InL . makeDiffTextEdit contents)+                    <$> try @OrmoluException (ormolu config fp' contents)+  where+    fp' = fromNormalizedFilePath fp+    title = "Formatting " <> T.pack (takeFileName fp')+    lspPrinterOpts = mempty{poIndentation = Just $ fromIntegral $ fo ^. tabSize}+    region = case typ of+        FormatText ->+            RegionIndices Nothing Nothing+        FormatRange (Range (Position sl _) (Position el _)) ->+            RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1)+    cliHandler :: FilePath -> [String] -> ExceptT PluginError IO ([TextEdit] |? Null)+    cliHandler path fileOpts = do+        CLIVersionInfo{noCabal} <- do -- check Fourmolu version so that we know which flags to use+            (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc path ["-v"] ) ""+            let version = do+                    guard $ exitCode == ExitSuccess+                    "fourmolu" : v : _ <- pure $ T.words out+                    traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v+            case version of+                Just v -> do+                    logWith recorder Debug $ LogExternalVersion v+                    pure CLIVersionInfo+                        { noCabal = v >= [0, 7]+                        }+                Nothing -> do+                    logWith recorder Debug $ LogExternalVersion []+                    logWith recorder Warning $ NoVersion out+                    pure CLIVersionInfo+                        { noCabal = True+                        }+        (exitCode, out, err) <- -- run Fourmolu+            liftIO $ readCreateProcessWithExitCode+                ( proc path $+                    map ("-o" <>) fileOpts+                        <> mwhen noCabal ["--no-cabal"]+                        <> catMaybes+                            [ ("--start-line=" <>) . show <$> regionStartLine region+                            , ("--end-line=" <>) . show <$> regionEndLine region+                            ]+                ){cwd = Just $ takeDirectory fp'}+                contents+        case exitCode of+            ExitSuccess -> do+                logWith recorder Debug $ StdErr err+                pure $ InL $ makeDiffTextEdit contents out+            ExitFailure n -> do+                logWith recorder Info $ StdErr err+                throwError $ PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n)++data LogEvent+    = NoVersion Text+    | ConfigPath FilePath+    | NoConfigPath [FilePath]+    | StdErr Text+    | LogCompiledInVersion String+    | LogExternalVersion [Int]+    deriving (Show)++instance Pretty LogEvent where+    pretty = \case+        NoVersion t -> "Couldn't get Fourmolu version:" <> line <> indent 2 (pretty t)+        ConfigPath p -> "Loaded Fourmolu config from: " <> pretty (show p)+        NoConfigPath ps -> "No " <> pretty configFileName <> " found in any of:"+            <> line <> indent 2 (vsep (map (pretty . show) ps))+        StdErr t -> "Fourmolu stderr:" <> line <> indent 2 (pretty t)+        LogCompiledInVersion v -> "Using compiled in fourmolu-" <> pretty v+        LogExternalVersion v ->+            "Using external fourmolu"+            <> if null v then "" else "-"+            <> pretty (intercalate "." $ map show v)++convertDynFlags :: DynFlags -> [String]+convertDynFlags df =+    let pp = ["-pgmF=" <> p | not (null p)]+        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+     in pp <> pm <> ex++newtype CLIVersionInfo = CLIVersionInfo+    { noCabal :: Bool+    }++mwhen :: Monoid a => Bool -> a -> a+mwhen b x = if b then x else mempty++#if !MIN_VERSION_fourmolu(0,14,0)+resolvePrinterOpts :: [PrinterOptsPartial] -> PrinterOptsTotal+resolvePrinterOpts = foldr fillMissingPrinterOpts defaultPrinterOpts+#endif
+ plugins/hls-fourmolu-plugin/test/Main.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+module Main+  ( main+  ) where++import           Data.Aeson+import qualified Data.Aeson.KeyMap           as KM+import           Data.Functor+import           Ide.Plugin.Config+import qualified Ide.Plugin.Fourmolu         as Fourmolu+import           Language.LSP.Protocol.Types+import           Language.LSP.Test+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++fourmoluPlugin :: PluginTestDescriptor Fourmolu.LogEvent+fourmoluPlugin = mkPluginTestDescriptor Fourmolu.descriptor "fourmolu"++tests :: TestTree+tests =+  testGroup "fourmolu" $+    [False, True] <&> \cli ->+      testGroup+        (if cli then "cli" else "lib")+        [ goldenWithFourmolu cli "formats correctly" "Fourmolu" "formatted" $ \doc -> do+            formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+        , goldenWithFourmolu cli "formats imports correctly" "Fourmolu2" "formatted" $ \doc -> do+            formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+        , goldenWithFourmolu cli "uses correct operator fixities" "Fourmolu3" "formatted" $ \doc -> do+            formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+        ]++goldenWithFourmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithFourmolu cli title path desc = goldenWithHaskellDocFormatter def fourmoluPlugin "fourmolu" conf title testDataDir path desc "hs"+ where+  conf = def{plcConfig = KM.fromList ["external" .= cli]}++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-fourmolu-plugin" </> "test" </> "testdata"
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.formatted.hs view
@@ -0,0 +1,16 @@+module Fourmolu where++import Data.List++import Data.Int+import Prelude++foo :: Int -> Int+foo 3 = 2+foo x = x+bar :: String -> IO String+bar s = do+    x <- return "hello"+    return "asdf"++data Baz = Baz {a :: Int, b :: String}
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.hs view
@@ -0,0 +1,15 @@+module    Fourmolu where+import Data.List++import Prelude+import Data.Int+foo   :: Int ->  Int+foo  3 = 2+foo    x  = x+bar   :: String ->   IO String+bar s =  do+      x <- return "hello"+      return "asdf"++data Baz = Baz { a :: Int, b :: String }+
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.formatted.hs view
@@ -0,0 +1,5 @@+import Data.Bool+import Data.Char+import Data.Data+import Data.Either+import Data.Int
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.hs view
@@ -0,0 +1,5 @@+import Data.Char+import Data.Either+import Data.Int+import Data.Data+import Data.Bool
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.formatted.hs view
@@ -0,0 +1,7 @@+b :: Bool+b =+    id $+        id $+            case True && True of+                True -> True+                False -> False
+ plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.hs view
@@ -0,0 +1,6 @@+b :: Bool+b =+    id $ id $+        case True && True of+            True -> True+            False -> False
+ plugins/hls-fourmolu-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}+module Ide.Plugin.GADT (descriptor) where++import           Control.Lens                     ((^.))++import           Control.Monad.Error.Class        (MonadError (throwError),+                                                   liftEither)+import           Control.Monad.IO.Class           (MonadIO)+import           Control.Monad.Trans.Class        (MonadTrans (lift))+import           Control.Monad.Trans.Except       (ExceptT, withExceptT)+import           Data.Aeson                       (FromJSON, ToJSON, toJSON)+import           Data.Either.Extra                (maybeToEither)+import qualified Data.Map                         as Map+import qualified Data.Text                        as T+import           Development.IDE+import           Development.IDE.GHC.Compat++import           Data.Maybe                       (mapMaybe)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Spans.Pragmas    (getFirstPragma,+                                                   insertNewPragma)+import           GHC.Generics                     (Generic)+import           Ide.Plugin.Error+import           Ide.Plugin.GHC+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens       as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server              (sendRequest)++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId "Provides a code action to convert datatypes to GADT syntax")+    { Ide.Types.pluginHandlers =+        mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler+    , pluginCommands =+        [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)]+    }++-- | Parameter used in the command+data ToGADTParams = ToGADTParams+    { uri   :: Uri+    , range :: Range+    } deriving (Generic, ToJSON, FromJSON)++toGADTSyntaxCommandId :: CommandId+toGADTSyntaxCommandId = "GADT.toGADT"++-- | A command replaces H98 data decl with GADT decl in place+toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams+toGADTCommand pId@(PluginId pId') state _ ToGADTParams{..} = withExceptT handleGhcidePluginError $ do+    nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE uri+    (decls, exts) <- getInRangeH98DeclsAndExts state range nfp+    (L ann decl) <- case decls of+        [d] -> pure d+        _   -> throwError $ UnexpectedNumberOfDeclarations (Prelude.length decls)+    deps <- withExceptT GhcidePluginErrors+        $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state+        $ useE GhcSessionDeps nfp+    (hsc_dflags . hscEnv -> df) <- pure deps+    txt <- withExceptT (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl+    range <- liftEither+        $ maybeToEither FailedToFindDataDeclRange+        $ srcSpanToRange $ locA ann+    pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp+    let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]]++    _ <- lift $ sendRequest+            SMethod_WorkspaceApplyEdit+            (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit)))+            (\_ -> pure ())++    pure $ InR Null+    where+        workSpaceEdit nfp edits = WorkspaceEdit+            (pure $ Map.fromList+                [(filePathToUri $ fromNormalizedFilePath nfp,+                edits)])+                 Nothing Nothing++codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT handleGhcidePluginError $ do+    nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE (doc ^. L.uri)+    (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp+    let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls+    pure $ InL actions+    where+        mkAction :: T.Text -> Command |? CodeAction+        mkAction name = InR CodeAction{..}+            where+                _title = "Convert \"" <> name <> "\" to GADT syntax"+                _kind = Just CodeActionKind_RefactorRewrite+                _diagnostics = Nothing+                _isPreferred = Nothing+                _disabled = Nothing+                _edit = Nothing+                _command = Just+                    $ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam])+                _data_ = Nothing++        mkParam = ToGADTParams (doc ^. L.uri) range++-- | Get all H98 decls in the given range, and enabled extensions+getInRangeH98DeclsAndExts :: (MonadIO m) =>+    IdeState+    -> Range+    -> NormalizedFilePath+    -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])+getInRangeH98DeclsAndExts state range nfp = do+    pm <- withExceptT GhcidePluginErrors+        $ runActionE "GADT.GetParsedModuleWithComments" state+        $ useE GetParsedModuleWithComments nfp+    let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm+        decls = filter isH98DataDecl+            $ mapMaybe getDataDecl+            $ filter (inRange range) hsDecls+        exts = getExtensions pm+    pure (decls, exts)++data GadtPluginError+    = UnexpectedNumberOfDeclarations Int+    | FailedToFindDataDeclRange+    | PrettyGadtError T.Text+    | GhcidePluginErrors PluginError++handleGhcidePluginError ::+    GadtPluginError ->+    PluginError+handleGhcidePluginError = \case+    UnexpectedNumberOfDeclarations nums -> do+        PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums)+    FailedToFindDataDeclRange ->+        PluginInternalError "Unable to get data decl range"+    PrettyGadtError errMsg ->+        PluginInternalError errMsg+    GhcidePluginErrors errors ->+        errors
+ plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+module Ide.Plugin.GHC where++import           Data.Functor                            ((<&>))+import           Data.List.Extra                         (stripInfix)+import qualified Data.Text                               as T+import           Development.IDE+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.ExactPrint+import           GHC.Parser.Annotation                   (AddEpAnn (..),+                                                          Anchor (Anchor),+                                                          AnchorOperation (MovedAnchor),+                                                          DeltaPos (..),+                                                          EpAnn (..),+                                                          EpAnnComments (EpaComments),+                                                          EpaLocation (EpaDelta),+                                                          SrcSpanAnn' (SrcSpanAnn),+                                                          spanAsAnchor)+import           Ide.PluginUtils                         (subRange)+import           Language.Haskell.GHC.ExactPrint         (showAst)+import           Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)++#if MIN_VERSION_ghc(9,5,0)+import qualified Data.List.NonEmpty                      as NE+import           GHC.Parser.Annotation                   (TokenLocation (..))+#endif++type GP = GhcPass Parsed++-- | Check if a given range is in the range of located item+inRange :: HasSrcSpan a => Range -> a -> Bool+inRange range s = maybe False (subRange range) (srcSpanToRange (getLoc s))++-- | Get data decl and its location+getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP)+getDataDecl (L l (TyClD _ d@DataDecl{})) = Just (L l d)+getDataDecl _                            = Nothing++isConDeclH98 :: ConDecl GP -> Bool+isConDeclH98 ConDeclH98{} = True+isConDeclH98 _            = False++isH98DataDecl :: LTyClDecl GP -> Bool+isH98DataDecl (L _ decl@DataDecl{}) =+    any (isConDeclH98 . (\(L _ r) -> r)) (dd_cons $ tcdDataDefn decl)+isH98DataDecl _ = False++-- | Convert H98 data type definition to GADT's+h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP+h98ToGADTDecl = \case+    DataDecl{..} -> DataDecl+        { tcdDataDefn = updateDefn tcdLName tcdTyVars tcdDataDefn+        , ..+        }+    x -> x+    where+        updateDefn dataName tyVars = \case+            HsDataDefn{..} -> HsDataDefn+                { dd_cons =+                    mapX (h98ToGADTConDecl dataName tyVars (wrapCtxt dd_ctxt)) <$> dd_cons+                , dd_ctxt = emptyCtxt -- Context can't appear at the data name in GADT+                , ..+                }+            x -> x++-- | Convert H98 data constructor to GADT data constructor+h98ToGADTConDecl ::+    LIdP GP -- ^Type constructor name,+            -- used for constructing final result type in GADT+    -> LHsQTyVars GP+            -- ^Type variable names+            -- used for constructing final result type in GADT+    -> Maybe (LHsContext GP)+            -- ^Data type context+    -> ConDecl GP+    -> ConDecl GP+h98ToGADTConDecl dataName tyVars ctxt = \case+    ConDeclH98{..} ->+        ConDeclGADT+            con_ext+#if MIN_VERSION_ghc(9,5,0)+            (NE.singleton con_name)+#else+            [con_name]+#endif++#if MIN_VERSION_ghc(9,5,0)+            (L NoTokenLoc HsNormalTok)+#endif+            -- Ignore all existential type variable since GADT not needed+            implicitTyVars+            (mergeContext ctxt con_mb_cxt)+            (renderDetails con_args)+            renderResultTy+            con_doc+    x -> x+    where+        -- Parameters in the data constructor+        renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP+        renderDetails (PrefixCon _ args)   = PrefixConGADT args+        renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2]+#if MIN_VERSION_ghc(9,3,0)+        renderDetails (RecCon recs)        = RecConGADT recs noHsUniTok+#else+        renderDetails (RecCon recs)        = RecConGADT recs+#endif+++        -- | Construct GADT result type+        renderResultTy :: LHsType GP+        renderResultTy = case tyVars of+            -- Without type variable+            HsQTvs _ []   -> wrappedDataName+            -- With type variable+            HsQTvs _ vars -> foldl go wrappedDataName vars+            _             -> wrappedDataName+            where+                wrappedDataName = wrap (HsTyVar noUsed NotPromoted dataName)++                -- Bundle data name with type vars by `HsAppTy`+                go acc (L _(UserTyVar' var)) =+                    wrap+                        (HsAppTy noExtField acc+                            (wrap (HsTyVar noUsed NotPromoted var)))+                go acc _ = acc++        -- Merge data type context and constructor type context+        mergeContext :: Maybe (LHsContext GP) -> Maybe (LHsContext GP) -> Maybe (LHsContext GP)+        mergeContext ctxt1 ctxt2 =+            (wrap . map wrap) . map unParTy+                <$> (getContextType ctxt1 <> getContextType ctxt2)+            where+                getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP]+                getContextType ctxt = map unWrap . unWrap <$> ctxt++                -- Unparen the outmost, it only occurs at the outmost+                -- for a valid type.+                --+                -- Note for context paren rule:+                --+                -- If only one element, it __can__ have a paren type.+                -- If not, there can't have a parent type.+                unParTy :: HsType GP -> HsType GP+                unParTy (HsParTy _ ty) = unWrap ty+                unParTy x              = x+{- |+We use `printOutputable` to print H98 data decl as GADT syntax,+this print is not perfect, it will:++1. Make data name and the `where` key word in different lines.+2. Make the whole data decl prints in one line if there is only one data constructor.+3. The ident size of every data constructor depends on its origin+   format, and may have different ident size between constructors.++Hence, we first use `printOutputable` to get an initial GADT syntax,+then use `ghc-exactprint` to parse the initial result, and finally+adjust the details that mentioned above.++The adjustment includes:++1. Make the `where` key word at the same line of data name.+2. Remove the extra blank line caused by adjustment of `where`.+3. Make every data constructor start with a new line and 2 spaces+-}+prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String+prettyGADTDecl df decl =+    let old = printOutputable decl+        hsDecl = parseDecl df "unused" (T.unpack old)+        tycld = adjustTyClD hsDecl+    in removeExtraEmptyLine . exactPrint <$> tycld+    where+        adjustTyClD = \case+                Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld+                Right x -> Left $ "Expect TyClD but got " <> showAst x+#if MIN_VERSION_ghc(9,3,0)+                Left err -> Left $ printWithoutUniques err+#else+                Left err -> Left $ show err+#endif++        adjustDataDecl DataDecl{..} = DataDecl+            { tcdDExt = adjustWhere tcdDExt+            , tcdDataDefn = tcdDataDefn+                { dd_cons =+                      fmap adjustCon (dd_cons tcdDataDefn)+                }+            , ..+            }+        adjustDataDecl x = x++        -- Make every data constructor start with a new line and 2 spaces+        adjustCon :: LConDecl GP -> LConDecl GP+        adjustCon (L (SrcSpanAnn _ loc) r) =+            L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r+            where+                go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2))++        -- Adjust where annotation to the same line of the type constructor+        adjustWhere tcdDExt = tcdDExt <&> map+            (\(AddEpAnn ann l) ->+            if ann == AnnWhere+                then AddEpAnn AnnWhere (EpaDelta (SameLine 1) [])+                else AddEpAnn ann l+            )++        -- Remove the first extra line if exist+        removeExtraEmptyLine s = case stripInfix "\n\n" s of+            Just (x, xs) -> x <> "\n" <> xs+            Nothing      -> s++wrap :: forall a. WrapXRec GP a => a -> XRec GP a+wrap = wrapXRec @GP+wrapCtxt = id+emptyCtxt = Nothing+unWrap = unXRec @GP+mapX = mapXRec @GP+noUsed = EpAnnNotUsed++pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass+pattern UserTyVar' s <- UserTyVar _ _ s++implicitTyVars = wrapXRec @GP mkHsOuterImplicit
+ plugins/hls-gadt-plugin/test/Main.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# OPTIONS_GHC -Wall #-}++module Main where++import           Control.Monad   (void)+import           Data.Either     (rights)+import qualified Data.Text       as T+import qualified Ide.Plugin.GADT as GADT+import           System.FilePath ((</>))+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++gadtPlugin :: PluginTestDescriptor ()+gadtPlugin = mkPluginTestDescriptor' GADT.descriptor "GADT"++tests :: TestTree+tests = testGroup "GADT"+    [ runTest "range" "SimpleData" 2 0 2 1+    , runTest "SimpleData" "SimpleData" 2 0 2 10+    , runTest "SimpleNewtype" "SimpleNewtype" 2 0 2 17+    , runTest "Data" "Data" 2 0 2 36+    , runTest "Newtype" "Newtype" 2 0 2 21+    , runTest "Deriving" "Deriving" 2 0 2 56+    , runTest "Infix" "Infix" 2 0 2 35+    , runTest "Record" "Record" 2 0 5 1+    , runTest "TypeVariable" "TypeVariable"  2 0 2 32+    , runTest "DataContext" "DataContext" 2 0 2 31+    , runTest "DataContextParen" "DataContextParen" 2 0 3 6+    , runTest "Forall" "Forall" 2 0 2 44+    , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38+    , runTest "Context" "Context" 2 0 4 41+    , runTest "Pragma" "Pragma" 2 0 3 29+    , runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14+    , gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False+    ]++gadtPragmaTest :: TestName -> Bool -> TestTree+gadtPragmaTest title hasGADT = testCase title+    $ withCanonicalTempDir+    $ \dir -> runSessionWithServer def gadtPlugin dir $ do+        doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"])+        _ <- waitForProgressDone+        (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1))+        executeCodeAction act+        let expected = T.unlines $+                ["{-# LANGUAGE GADTs #-}" | hasGADT] +++                ["module A where", "data Foo where", "  Bar :: Foo"]+        contents <- skipManyTill anyMessage (getDocumentEdit doc)+        liftIO $ contents @?= expected++runTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree+runTest title fp x1 y1 x2 y2 =+    goldenWithHaskellDoc def gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do+        _ <- waitForProgressDone+        (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position x1 y1) (Position x2 y2))+        executeCodeAction act+        void $ skipManyTill anyMessage (getDocumentEdit doc)++findGADTAction :: [a |? CodeAction] -> [CodeAction]+findGADTAction = filter isGADTCodeAction . rights . map toEither++isGADTCodeAction :: CodeAction -> Bool+isGADTCodeAction CodeAction{..} = case _kind of+    Nothing -> False+    Just kind -> case kind of+        CodeActionKind_RefactorRewrite -> True+        _                              -> False++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-gadt-plugin" </> "test" </> "testdata"
+ plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs view
@@ -0,0 +1,4 @@+module ConstructorContext where++data Foo where+  Bar :: Show a => a -> Foo
+ plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs view
@@ -0,0 +1,3 @@+module ConstructorContext where++data Foo = forall a. (Show a) => Bar a
+ plugins/hls-gadt-plugin/test/testdata/Context.expected.hs view
@@ -0,0 +1,5 @@+module Context where++data Foo a where+  Bar :: (Eq a, Show b, Show a) => a -> b -> Foo a+  Baz :: (Eq a, Show c) => c -> c -> Foo a
+ plugins/hls-gadt-plugin/test/testdata/Context.hs view
@@ -0,0 +1,5 @@+module Context where++data (Eq a) => Foo a =+    forall b c. (Show b, Show a) =>+  Bar a b | forall c. (Show c) => Baz c c
+ plugins/hls-gadt-plugin/test/testdata/Data.expected.hs view
@@ -0,0 +1,5 @@+module Data where++data Foo where+  Bar :: Int -> Foo+  Baz :: Char -> String -> Foo
+ plugins/hls-gadt-plugin/test/testdata/Data.hs view
@@ -0,0 +1,3 @@+module Data where++data Foo = Bar Int | Baz Char String
+ plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs view
@@ -0,0 +1,5 @@+module DataContext where++data T a b where+  F :: Ord a => a -> T a b+  G :: Ord a => b -> T a b
+ plugins/hls-gadt-plugin/test/testdata/DataContext.hs view
@@ -0,0 +1,3 @@+module DataContext where++data Ord a => T a b = F a | G b
+ plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs view
@@ -0,0 +1,4 @@+module DataContextParen where++data F a where+  G :: Eq a => a -> F a
+ plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs view
@@ -0,0 +1,4 @@+module DataContextParen where++data (Eq a) => F a+ = G a
+ plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs view
@@ -0,0 +1,6 @@+module Deriving where++data Foo where+  Bar :: Int -> Foo+  Baz :: Char -> String -> Foo+  deriving (Show, Eq)
+ plugins/hls-gadt-plugin/test/testdata/Deriving.hs view
@@ -0,0 +1,3 @@+module Deriving where++data Foo = Bar Int | Baz Char String deriving (Show, Eq)
+ plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs view
@@ -0,0 +1,4 @@+module Forall where++data Foo where+  Bar :: Show a => a -> b -> a -> Foo
+ plugins/hls-gadt-plugin/test/testdata/Forall.hs view
@@ -0,0 +1,3 @@+module Forall where++data Foo = forall a b. (Show a) => Bar a b a
+ plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs view
@@ -0,0 +1,5 @@+module Infix where++data Foo where+  (:->) :: Int -> Char -> Foo+  deriving ()
+ plugins/hls-gadt-plugin/test/testdata/Infix.hs view
@@ -0,0 +1,3 @@+module Infix where++data Foo = Int :-> Char deriving ()
+ plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs view
@@ -0,0 +1,4 @@+module Newtype where++newtype Foo where+  Bar :: Int -> Foo
+ plugins/hls-gadt-plugin/test/testdata/Newtype.hs view
@@ -0,0 +1,3 @@+module Newtype where++newtype Foo = Bar Int
+ plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs view
@@ -0,0 +1,5 @@+module Pragma where++data F where+  G :: {-# UNPACK #-}Int -> F+  H :: {-# NOUNPACK #-}Char -> F
+ plugins/hls-gadt-plugin/test/testdata/Pragma.hs view
@@ -0,0 +1,4 @@+module Pragma where++data F = G{-# UNPACK #-}Int+    | H {-# NOUNPACK #-} Char
+ plugins/hls-gadt-plugin/test/testdata/Record.expected.hs view
@@ -0,0 +1,4 @@+module Record where++data Foo where+  Foo :: {bar :: Char, baz :: Int} -> Foo
+ plugins/hls-gadt-plugin/test/testdata/Record.hs view
@@ -0,0 +1,6 @@+module Record where++data Foo = Foo {+    bar :: Char,+    baz :: Int+}
+ plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs view
@@ -0,0 +1,4 @@+module SimpleData where++data A where+  B :: A
+ plugins/hls-gadt-plugin/test/testdata/SimpleData.hs view
@@ -0,0 +1,3 @@+module SimpleData where++data A = B
+ plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs view
@@ -0,0 +1,4 @@+module SimpleNewtype where++newtype A where+  B :: Int -> A
+ plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs view
@@ -0,0 +1,3 @@+module SimpleNewtype where++newtype A = B Int
+ plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs view
@@ -0,0 +1,5 @@+module SingleDeriving where++data Foo a b where+  Bar :: b -> a -> Foo a b+  deriving Eq
+ plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs view
@@ -0,0 +1,4 @@+module SingleDeriving where++data Foo a b = Bar b a+ deriving (Eq)
+ plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs view
@@ -0,0 +1,5 @@+module SingleDerivingGHC92 where++data Foo a b where+  Bar :: b -> a -> Foo a b+  deriving (Eq)
+ plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs view
@@ -0,0 +1,4 @@+module SingleDerivingGHC92 where++data Foo a b = Bar b a+ deriving (Eq)
+ plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs view
@@ -0,0 +1,5 @@+module TypeVariable where++data Foo a f where+  Foo :: a -> Foo a f+  Bar :: (f a) -> Foo a f
+ plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs view
@@ -0,0 +1,3 @@+module TypeVariable where++data Foo a f = Foo a | Bar (f a)
+ plugins/hls-gadt-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: ["-XHaskell2010", "-XExistentialQuantification", "-XGADTs"]
+ plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs view
@@ -0,0 +1,687 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE StrictData            #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}+{-# OPTIONS_GHC -Wno-orphans   #-}++-- On 9.4 we get a new redundant constraint warning, but deleting the+-- constraint breaks the build on earlier versions. Rather than apply+-- lots of CPP, we just disable the warning until later.+{-# OPTIONS_GHC -Wno-redundant-constraints   #-}++#ifdef HLINT_ON_GHC_LIB+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)+#else+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)+#endif++module Ide.Plugin.Hlint+  (+    descriptor+  , Log(..)+  ) where+import           Control.Arrow                                      ((&&&))+import           Control.Concurrent.STM+import           Control.DeepSeq+import           Control.Exception+import           Control.Lens                                       ((?~), (^.))+import           Control.Monad+import           Control.Monad.Error.Class                          (MonadError (throwError))+import           Control.Monad.IO.Class                             (MonadIO (liftIO))+import           Control.Monad.Trans.Class                          (MonadTrans (lift))+import           Control.Monad.Trans.Except                         (ExceptT (..),+                                                                     runExceptT)+import           Data.Aeson.Types                                   (FromJSON (..),+                                                                     ToJSON (..),+                                                                     Value (..))+import qualified Data.ByteString                                    as BS+import           Data.Hashable+import qualified Data.HashMap.Strict                                as Map+import qualified Data.Map                                           as M+import           Data.Maybe+import qualified Data.Text                                          as T+import qualified Data.Text.Encoding                                 as T+import           Data.Typeable+import           Development.IDE                                    hiding+                                                                    (Error,+                                                                     getExtensions)+import           Development.IDE.Core.Compile                       (sourceParser)+import           Development.IDE.Core.Rules                         (defineNoFile,+                                                                     getParsedModuleWithComments)+import           Development.IDE.Core.Shake                         (getDiagnostics)+import qualified Refact.Apply                                       as Refact+import qualified Refact.Types                                       as Refact++#ifdef HLINT_ON_GHC_LIB+import           Development.IDE.GHC.Compat                         (DynFlags,+                                                                     WarningFlag (Opt_WarnUnrecognisedPragmas),+                                                                     extensionFlags,+                                                                     ms_hspp_opts,+                                                                     topDir,+                                                                     wopt)+import qualified Development.IDE.GHC.Compat.Util                    as EnumSet++#if MIN_GHC_API_VERSION(9,4,0)+import qualified "ghc-lib-parser" GHC.Data.Strict                   as Strict+#endif+#if MIN_GHC_API_VERSION(9,0,0)+import           "ghc-lib-parser" GHC.Types.SrcLoc                  hiding+                                                                    (RealSrcSpan)+import qualified "ghc-lib-parser" GHC.Types.SrcLoc                  as GHC+#else+import           "ghc-lib-parser" SrcLoc                            hiding+                                                                    (RealSrcSpan)+import qualified "ghc-lib-parser" SrcLoc                            as GHC+#endif+import           "ghc-lib-parser" GHC.LanguageExtensions            (Extension)+import           Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)+import           System.FilePath                                    (takeFileName)+import           System.IO                                          (IOMode (WriteMode),+                                                                     hClose,+                                                                     hPutStr,+                                                                     hSetEncoding,+                                                                     hSetNewlineMode,+                                                                     noNewlineTranslation,+                                                                     utf8,+                                                                     withFile)+import           System.IO.Temp+#else+import           Development.IDE.GHC.Compat                         hiding+                                                                    (setEnv,+                                                                     (<+>))+import           GHC.Generics                                       (Associativity (LeftAssociative, NotAssociative, RightAssociative))+#if MIN_GHC_API_VERSION(9,2,0)+import           Language.Haskell.GHC.ExactPrint.ExactPrint         (deltaOptions)+#else+import           Language.Haskell.GHC.ExactPrint.Delta              (deltaOptions)+#endif+import           Language.Haskell.GHC.ExactPrint.Parsers            (postParseTransform)+import           Language.Haskell.GHC.ExactPrint.Types              (Rigidity (..))+import           Language.Haskell.GhclibParserEx.Fixity             as GhclibParserEx (applyFixities)+import qualified Refact.Fixity                                      as Refact+#endif+import           Ide.Plugin.Config                                  hiding+                                                                    (Config)+import           Ide.Plugin.Error+import           Ide.Plugin.Properties+import           Ide.Plugin.Resolve+import           Ide.PluginUtils+import           Ide.Types                                          hiding+                                                                    (Config)+import           Language.Haskell.HLint                             as Hlint+import qualified Language.LSP.Protocol.Lens                         as LSP+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types                        hiding+                                                                    (Null)+import qualified Language.LSP.Protocol.Types                        as LSP+import           Language.LSP.Server                                (getVersionedTextDoc)++import qualified Development.IDE.Core.Shake                         as Shake+import           Development.IDE.Spans.Pragmas                      (LineSplitTextEdits (LineSplitTextEdits),+                                                                     NextPragmaInfo (NextPragmaInfo),+                                                                     getNextPragmaInfo,+                                                                     lineSplitDeleteTextEdit,+                                                                     lineSplitInsertTextEdit,+                                                                     lineSplitTextEdits,+                                                                     nextPragmaLine)+import           GHC.Generics                                       (Generic)+#if !MIN_VERSION_apply_refact(0,12,0)+import           System.Environment                                 (setEnv,+                                                                     unsetEnv)+#endif+import           Development.IDE.Core.PluginUtils                   as PluginUtils+import           Text.Regex.TDFA.Text                               ()+-- ---------------------------------------------------------------------++data Log+  = LogShake Shake.Log+  | LogApplying NormalizedFilePath (Either String WorkspaceEdit)+  | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]]+  | LogGetIdeas NormalizedFilePath+  | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them+  | forall a. (Pretty a) => LogResolve a++instance Pretty Log where+  pretty = \case+    LogShake log -> pretty log+    LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res+    LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas+    LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts+    LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp+    LogResolve msg -> pretty msg++#ifdef HLINT_ON_GHC_LIB+-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib+#if !MIN_GHC_API_VERSION(9,0,0)+type BufSpan = ()+#endif+pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan+#if MIN_GHC_API_VERSION(9,4,0)+pattern RealSrcSpan x y <- GHC.RealSrcSpan x (fromStrictMaybe -> y)+#elif MIN_GHC_API_VERSION(9,0,0)+pattern RealSrcSpan x y = GHC.RealSrcSpan x y+#else+pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))+#endif+{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}+#endif++#if MIN_GHC_API_VERSION(9,4,0)+fromStrictMaybe :: Strict.Maybe a -> Maybe a+fromStrictMaybe (Strict.Just a ) = Just a+fromStrictMaybe  Strict.Nothing  = Nothing+#endif++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  let resolveRecorder = cmapWithPrio LogResolve recorder+      (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder)+      desc = "Provides HLint diagnostics and code actions. Built with hlint-" <> VERSION_hlint+  in (defaultPluginDescriptor plId desc)+  { pluginRules = rules recorder plId+  , pluginCommands = pluginCommands+  , pluginHandlers = pluginHandlers+  , pluginConfigDescriptor = defaultConfigDescriptor+      { configHasDiagnostics = True+      , configCustomConfig = mkCustomConfig properties+      }+  }++-- This rule only exists for generating file diagnostics+-- so the RuleResult is empty+data GetHlintDiagnostics = GetHlintDiagnostics+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetHlintDiagnostics+instance NFData   GetHlintDiagnostics++type instance RuleResult GetHlintDiagnostics = ()++-- | Hlint rules to generate file diagnostics based on hlint hints+-- | This rule is recomputed when:+-- | - A file has been edited via+-- |    - `getIdeas` -> `getParsedModule` in any case+-- |    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc+-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`+-- | - The hlint specific settings have changed, via `getHlintSettingsRule`+rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+rules recorder plugin = do+  define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do+    config <- getPluginConfigAction plugin+    let hlintOn = plcGlobalOn config && plcDiagnosticsOn config+    ideas <- if hlintOn then getIdeas recorder file else return (Right [])+    return (diagnostics file ideas, Just ())++  defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do+    (Config flags) <- getHlintConfig plugin+    liftIO $ argsSettings flags++  action $ do+    files <- getFilesOfInterestUntracked+    void $ uses GetHlintDiagnostics $ Map.keys files++  where++      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]+      diagnostics file (Right ideas) =+       (file, ShowDiag,) <$> catMaybes [ideaToDiagnostic i | i <- ideas]+      diagnostics file (Left parseErr) =+        [(file, ShowDiag, parseErrorToDiagnostic parseErr)]+++      ideaToDiagnostic :: Idea -> Maybe Diagnostic+      ideaToDiagnostic idea = do+        diagnosticSeverity <- ideaSeverityToDiagnosticSeverity (ideaSeverity idea)+        pure $+            LSP.Diagnostic {+              _range    = srcSpanToRange $ ideaSpan idea+            , _severity = Just diagnosticSeverity+            -- we are encoding the fact that idea has refactorings in diagnostic code+            , _code     = Just (InR $ T.pack $ codePre ++ ideaHint idea)+            , _source   = Just "hlint"+            , _message  = idea2Message idea+            , _relatedInformation = Nothing+            , _tags     = Nothing+            , _codeDescription = Nothing+            , _data_ = Nothing+            }++        where+          codePre = if null $ ideaRefactoring idea then "" else "refact:"++          -- We only propogate error severity of hlint and downgrade other severities to Info.+          -- Currently, there are just 2 error level serverities present in hlint by default: https://github.com/ndmitchell/hlint/issues/1549#issuecomment-1892701824.+          -- And according to ndmitchell: The default error level severities of the two hints are justified and it's fairly uncommon to happen.+          -- GH Issue about discussion on this: https://github.com/ndmitchell/hlint/issues/1549+          ideaSeverityToDiagnosticSeverity :: Hlint.Severity -> Maybe LSP.DiagnosticSeverity+          ideaSeverityToDiagnosticSeverity Hlint.Ignore = Nothing+          ideaSeverityToDiagnosticSeverity Hlint.Suggestion = Just LSP.DiagnosticSeverity_Information+          ideaSeverityToDiagnosticSeverity Hlint.Warning = Just LSP.DiagnosticSeverity_Information+          ideaSeverityToDiagnosticSeverity Hlint.Error = Just LSP.DiagnosticSeverity_Error++      idea2Message :: Idea -> T.Text+      idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", "  " <> T.pack (ideaFrom idea)]+                                     <> toIdea <> map (T.pack . show) (ideaNote idea)+        where+          toIdea :: [T.Text]+          toIdea = case ideaTo idea of+            Nothing -> []+            Just i  -> [T.pack "Why not:", T.pack $ "  " ++ i]+++      parseErrorToDiagnostic :: ParseError -> Diagnostic+      parseErrorToDiagnostic (Hlint.ParseError l msg contents) =+        LSP.Diagnostic {+            _range    = srcSpanToRange l+          , _severity = Just LSP.DiagnosticSeverity_Information+          , _code     = Just (InR sourceParser)+          , _source   = Just "hlint"+          , _message  = T.unlines [T.pack msg,T.pack contents]+          , _relatedInformation = Nothing+          , _tags     = Nothing+          , _codeDescription = Nothing+          , _data_ = Nothing+        }++      -- This one is defined in Development.IDE.GHC.Error but here+      -- the types could come from ghc-lib or ghc+      srcSpanToRange :: SrcSpan -> LSP.Range+      srcSpanToRange (RealSrcSpan span _) = Range {+          _start = LSP.Position {+                _line = fromIntegral $ srcSpanStartLine span - 1+              , _character  = fromIntegral $ srcSpanStartCol span - 1}+        , _end   = LSP.Position {+                _line = fromIntegral $ srcSpanEndLine span - 1+             , _character = fromIntegral $ srcSpanEndCol span - 1}+        }+      srcSpanToRange (UnhelpfulSpan _) = noRange++getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea])+getIdeas recorder nfp = do+  logWith recorder Debug $ LogGetIdeas nfp+  (flags, classify, hint) <- useNoFile_ GetHlintSettings++  let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx]+      applyHints' (Just (Left err)) = Left err+      applyHints' Nothing = Right []++  fmap applyHints' (moduleEx flags)++  where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))+#ifndef HLINT_ON_GHC_LIB+        moduleEx _flags = do+          mbpm <- getParsedModuleWithComments nfp+          return $ createModule <$> mbpm+          where+            createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))+                  where anns = pm_annotations pm+                        modu = pm_parsed_source pm++            applyParseFlagsFixities :: ParsedSource -> ParsedSource+            applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul++            parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]+            parseFlagsToFixities = map toFixity . Hlint.fixities++            toFixity :: FixityInfo -> (String, Fixity)+            toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)+                where+                    f LeftAssociative  = InfixL+                    f RightAssociative = InfixR+                    f NotAssociative   = InfixN+#else+        moduleEx flags = do+          mbpm <- getParsedModuleWithComments nfp+          -- If ghc was not able to parse the module, we disable hlint diagnostics+          if isNothing mbpm+              then return Nothing+              else do+                     flags' <- setExtensions flags+                     (_, contents) <- getFileContents nfp+                     let fp = fromNormalizedFilePath nfp+                     let contents' = T.unpack <$> contents+                     Just <$> liftIO (parseModuleEx flags' fp contents')++        setExtensions flags = do+          hlintExts <- getExtensions nfp+          logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts)+          return $ flags { enabledExtensions = hlintExts }++-- Gets extensions from ModSummary dynflags for the file.+-- Previously this would union extensions from both hlint's parsedFlags+-- and the ModSummary dynflags. However using the parsedFlags extensions+-- can sometimes interfere with the hlint parsing of the file.+-- See https://github.com/haskell/haskell-language-server/issues/1279+--+-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need+-- these extensions to construct dynflags to parse the file again. Therefore+-- using hlint default extensions doesn't seem to be a problem when+-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again.+getExtensions :: NormalizedFilePath -> Action [Extension]+getExtensions nfp = do+    dflags <- getFlags+    let hscExts = EnumSet.toList (extensionFlags dflags)+    let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts+    return hscExts'+  where getFlags :: Action DynFlags+        getFlags = do+          modsum <- use_ GetModSummary nfp+          return $ ms_hspp_opts $ msrModSummary modsum+#endif++-- ---------------------------------------------------------------------++data GetHlintSettings = GetHlintSettings+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetHlintSettings+instance NFData   GetHlintSettings+instance NFData Hint where rnf = rwhnf+instance NFData Classify where rnf = rwhnf+instance NFData ParseFlags where rnf = rwhnf+instance Show Hint where show = const "<hint>"+instance Show ParseFlags where show = const "<parseFlags>"++type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)++-- ---------------------------------------------------------------------++newtype Config = Config [String]++properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]+properties = emptyProperties+  & defineArrayProperty #flags+    "Flags used by hlint" []++-- | Get the plugin config+getHlintConfig :: PluginId -> Action Config+getHlintConfig pId =+  Config+    <$> usePropertyAction #flags pId properties++-- ---------------------------------------------------------------------+codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context)+  | let TextDocumentIdentifier uri = documentId+  , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri)+  = do+    verTxtDocId <- lift $ getVersionedTextDoc documentId+    liftIO $ fmap (InL . map LSP.InR) $ do+      allDiagnostics <- atomically $ getDiagnostics ideState++      let numHintsInDoc = length+            [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics+                        , validCommand diagnostic+                        , diagnosticNormalizedFilePath == docNormalizedFilePath+            ]+      let numHintsInContext = length+            [diagnostic | diagnostic <- diags+                        , validCommand diagnostic+            ]+      let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId+      if numHintsInDoc > 1 && numHintsInContext > 0 then do+        pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId]+      else+        pure singleHintCodeActions+  | otherwise+  = pure $ InL []++  where+    applyAllAction verTxtDocId =+      let args = Just $ toJSON (ApplyHint verTxtDocId Nothing)+        in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args++    -- |Some hints do not have an associated refactoring+    validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) =+        "refact:" `T.isPrefixOf` code+    validCommand _ =+        False++    diags = context ^. LSP.diagnostics++resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve+resolveProvider recorder ideState _plId ca uri resolveValue = do+  file <-  getNormalizedFilePathE uri+  case resolveValue of+    (ApplyHint verTxtDocId oneHint) -> do+        edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId+        pure $ ca & LSP.edit ?~ edit+    (IgnoreHint verTxtDocId hintTitle ) -> do+        edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle+        pure $ ca & LSP.edit ?~ edit++-- | Convert a hlint diagnostic into an apply and an ignore code action+-- if applicable+diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]+diagnosticToCodeActions verTxtDocId diagnostic+  | LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic+  , let isHintApplicable = "refact:" `T.isPrefixOf` code+  , let hint = T.replace "refact:" "" code+  , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"+  , let suppressHintArguments = IgnoreHint verTxtDocId hint+  = catMaybes+      -- Applying the hint is marked preferred because it addresses the underlying error.+      -- Disabling the rule isn't, because less often used and configuration can be adapted.+      [ if | isHintApplicable+           , let applyHintTitle = "Apply hint \"" <> hint <> "\""+                 applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) ->+               Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True)+           | otherwise -> Nothing+      , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False)+      ]+  | otherwise = []++mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction+mkCodeAction title diagnostic data_  isPreferred =+  LSP.CodeAction+    { _title = title+    , _kind = Just LSP.CodeActionKind_QuickFix+    , _diagnostics = Just [diagnostic]+    , _isPreferred = Just isPreferred+    , _disabled = Nothing+    , _edit = Nothing+    , _command = Nothing+    , _data_ = data_+    }++mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]+mkSuppressHintTextEdits dynFlags fileContents hint =+  let+    NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents)+    nextPragmaLinePosition = Position (fromIntegral nextPragmaLine) 0+    nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition+    wnoUnrecognisedPragmasText =+      if wopt Opt_WarnUnrecognisedPragmas dynFlags+      then Just "{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n"+      else Nothing+    hlintIgnoreText = Just ("{-# HLINT ignore \"" <> hint <> "\" #-}\n")+    -- we combine the texts into a single text because lsp-test currently+    -- applies text edits backwards and I want the options pragma to+    -- appear above the hlint pragma in the tests+    combinedText = mconcat $ catMaybes [wnoUnrecognisedPragmasText, hlintIgnoreText]+    combinedTextEdit = LSP.TextEdit nextPragmaRange combinedText+    lineSplitTextEditList = maybe [] (\LineSplitTextEdits{..} -> [lineSplitInsertTextEdit, lineSplitDeleteTextEdit]) lineSplitTextEdits+  in+    combinedTextEdit : lineSplitTextEditList+-- ---------------------------------------------------------------------++ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)+ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do+  (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp+  (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp+  case fileContents of+    Just contents -> do+        let dynFlags = ms_hspp_opts $ msrModSummary msr+            textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle+            workspaceEdit =+                LSP.WorkspaceEdit+                  (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits))+                  Nothing+                  Nothing+        pure workspaceEdit+    Nothing -> throwError $ PluginInternalError "Unable to get fileContents"++-- ---------------------------------------------------------------------+data HlintResolveCommands =+    ApplyHint+      { verTxtDocId :: VersionedTextDocumentIdentifier+      -- |If Nothing, apply all hints, otherise only apply+      -- the given hint+      , oneHint     :: Maybe OneHint+      }+  | IgnoreHint+      { verTxtDocId     :: VersionedTextDocumentIdentifier+      , ignoreHintTitle :: HintTitle+      } deriving (Generic, ToJSON, FromJSON)++type HintTitle = T.Text++data OneHint =+  OneHint+    { oneHintPos   :: Position+    , oneHintTitle :: HintTitle+    } deriving (Generic, Eq, Show, ToJSON, FromJSON)++applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)+applyHint recorder ide nfp mhint verTxtDocId =+  runExceptT $ do+    let runAction' :: Action a -> IO a+        runAction' = runAction "applyHint" ide+    let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException)))+                        , Handler $ \e -> return (Left (show (e :: ErrorCall)))+                        ]+    ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp+    let ideas' = maybe ideas (`filterIdeas` ideas) mhint+    let commands = map ideaRefactoring ideas'+    logWith recorder Debug $ LogGeneratedIdeas nfp commands+    let fp = fromNormalizedFilePath nfp+    (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp+    oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent+    modsum <- liftIO $ runAction' $ use_ GetModSummary nfp+    let dflags = ms_hspp_opts $ msrModSummary modsum++    -- set Nothing as "position" for "applyRefactorings" because+    -- applyRefactorings expects the provided position to be _within_ the scope+    -- of each refactoring it will apply.+    -- But "Idea"s returned by HLint point to starting position of the expressions+    -- that contain refactorings, so they are often outside the refactorings' boundaries.+    let position = Nothing+#ifdef HLINT_ON_GHC_LIB+    let writeFileUTF8NoNewLineTranslation file txt =+            withFile file WriteMode $ \h -> do+                hSetEncoding h utf8+                hSetNewlineMode h noNewlineTranslation+                hPutStr h (T.unpack txt)+    res <-+        liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do+            hClose h+            writeFileUTF8NoNewLineTranslation temp oldContent+            exts <- runAction' $ getExtensions nfp+            -- We have to reparse extensions to remove the invalid ones+            let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts+            let refactExts = map show $ enabled ++ disabled+            (Right <$> applyRefactorings (topDir dflags) position commands temp refactExts)+                `catches` errorHandlers+#else+    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp+    res <-+        case mbParsedModule of+            Nothing -> throwError "Apply hint: error parsing the module"+            Just pm -> do+                let anns = pm_annotations pm+                let modu = pm_parsed_source pm+                -- apply-refact uses RigidLayout+                let rigidLayout = deltaOptions RigidLayout+                (anns', modu') <-+                    ExceptT $ mapM (uncurry Refact.applyFixities)+                            $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout+                liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')+                            `catches` errorHandlers+#endif+    case res of+      Right appliedFile -> do+        let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions+        ExceptT $ return (Right wsEdit)+      Left err ->+        throwError $ PluginInternalError $ T.pack err+    where+          -- | If we are only interested in applying a particular hint then+          -- let's filter out all the irrelevant ideas+          filterIdeas :: OneHint -> [Idea] -> [Idea]+          filterIdeas (OneHint (Position l c) title) ideas =+            let title' = T.unpack title+                ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan+            in filter (\i -> ideaHint i == title' && ideaPos i == (fromIntegral $ l+1, fromIntegral $ c+1)) ideas++          toRealSrcSpan (RealSrcSpan real _) = real+          toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x++          showParseError :: Hlint.ParseError -> String+          showParseError (Hlint.ParseError location message content) =+            unlines [show location, message, content]++-- | Map over both failure and success.+bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b+bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where+  h (Left e)  = Left (f e)+  h (Right a) = Right (g a)+{-# INLINE bimapExceptT #-}++-- ---------------------------------------------------------------------------+-- Apply-refact compatability, documentation copied from upstream apply-refact+-- ---------------------------------------------------------------------------++-- | Apply a set of refactorings as supplied by HLint+--+-- This compatibility function abstracts over https://github.com/mpickering/apply-refact/issues/133+-- for backwards compatability.+applyRefactorings ::+  -- | FilePath to [GHC's libdir](https://downloads.haskell.org/ghc/latest/docs/users_guide/using.html#ghc-flag---print-libdir).+  --+  -- It is possible to use @libdir@ from [ghc-paths package](https://hackage.haskell.org/package/ghc-paths), but note+  -- this will make it difficult to provide a binary distribution of your program.+  FilePath ->+  -- | Apply hints relevant to a specific position+  Maybe (Int, Int) ->+  -- | 'Refactoring's to apply. Each inner list corresponds to an HLint+  -- <https://hackage.haskell.org/package/hlint/docs/Language-Haskell-HLint.html#t:Idea Idea>.+  -- An @Idea@ may have more than one 'Refactoring'.+  --+  -- The @Idea@s are sorted in ascending order of starting location, and are applied+  -- in that order. If two @Idea@s start at the same location, the one with the larger+  -- source span comes first. An @Idea@ is filtered out (ignored) if there is an @Idea@+  -- prior to it which has an overlapping source span and is not filtered out.+  [[Refact.Refactoring Refact.SrcSpan]] ->+  -- | Target file+  FilePath ->+  -- | GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left+  -- to right. An extension (e.g., @StarIsType@) may be overridden later (e.g., by @NoStarIsType@).+  --+  -- These are in addition to the @LANGUAGE@ pragmas in the target file. When they conflict+  -- with the @LANGUAGE@ pragmas, pragmas win.+  [String] ->+  IO String+applyRefactorings =+#if MIN_VERSION_apply_refact(0,12,0)+  Refact.applyRefactorings+#else+  \libdir pos refacts fp exts -> withRuntimeLibdir libdir (Refact.applyRefactorings pos refacts fp exts)++  where+    -- Setting a environment variable with the libdir used by ghc-exactprint.+    -- It is a workaround for an error caused by the use of a hardcoded at compile time libdir+    -- in ghc-exactprint that makes dependent executables non portables.+    -- See https://github.com/alanz/ghc-exactprint/issues/96.+    -- WARNING: this code is not thread safe, so if you try to apply several async refactorings+    -- it could fail. That case is not very likely so we assume the risk.+    withRuntimeLibdir :: FilePath -> IO a -> IO a+    withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)+        where key = "GHC_EXACTPRINT_GHC_LIBDIR"+#endif
+ plugins/hls-hlint-plugin/test/Main.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+module Main+  ( main+  ) where++import           Control.Lens               ((^.))+import           Control.Monad              (when)+import           Data.Aeson                 (Value (..), object, (.=))+import           Data.Functor               (void)+import           Data.List                  (find)+import qualified Data.Map                   as Map+import           Data.Maybe                 (fromJust, isJust)+import           Data.Row                   ((.+), (.==))+import qualified Data.Text                  as T+import           Ide.Plugin.Config          (Config (..))+import qualified Ide.Plugin.Config          as Plugin+import qualified Ide.Plugin.Hlint           as HLint+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath            ((</>))+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++hlintPlugin :: PluginTestDescriptor HLint.Log+hlintPlugin = mkPluginTestDescriptor HLint.descriptor "hlint"++tests :: TestTree+tests = testGroup "hlint" [+      suggestionsTests+    , configTests+    , ignoreHintTests+    , applyHintTests+    , resolveTests+    ]++getIgnoreHintText :: T.Text -> T.Text+getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module"++getApplyHintText :: T.Text -> T.Text+getApplyHintText name = "Apply hint \"" <> name <> "\""++resolveTests :: TestTree+resolveTests = testGroup "hlint resolve tests"+  [+    ignoreHintGoldenResolveTest+      "Resolve version of: Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off"+      "UnrecognizedPragmasOff"+      (Point 3 8)+      "Eta reduce"+  , applyHintGoldenResolveTest+      "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left"+      "RightToLeftFixities"+      (Point 6 13)+      "Avoid reverse"+  ]+++ignoreHintTests :: TestTree+ignoreHintTests = testGroup "hlint ignore hint tests"+  [+    ignoreHintGoldenTest+      "Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off"+      "UnrecognizedPragmasOff"+      (Point 3 8)+      "Eta reduce"+  , ignoreHintGoldenTest+      "Ignore hint in this module inserts only hlint ignore pragma if warn unrecognized pragmas is on"+      "UnrecognizedPragmasOn"+      (Point 3 9)+      "Eta reduce"+  ]++applyHintTests :: TestTree+applyHintTests = testGroup "hlint apply hint tests"+  [+    applyHintGoldenTest+      "[#2612] Apply hint works when operator fixities go right-to-left"+      "RightToLeftFixities"+      (Point 6 13)+      "Avoid reverse"+  ]++suggestionsTests :: TestTree+suggestionsTests =+  testGroup "hlint suggestions" [+    testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do+        doc <- openDoc "Base.hs" "haskell"+        diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint"++        liftIO $ do+            length diags @?= 2 -- "Eta Reduce" and "Redundant Id"+            reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12)+            reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Information+            reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce")+            reduceDiag ^. L.source @?= Just "hlint"++        cas <- map fromAction <$> getAllCodeActions doc++        let redundantIdHintName = "Redundant id"+        let etaReduceHintName = "Eta reduce"+        let applyAll = find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) cas+        let redId = find (\ca -> redundantIdHintName `T.isInfixOf` (ca ^. L.title)) cas+        let redEta = find (\ca -> etaReduceHintName `T.isInfixOf` (ca ^. L.title)) cas+        let ignoreRedundantIdInThisModule = find (\ca -> getIgnoreHintText redundantIdHintName == (ca ^.L.title)) cas+        let ignoreEtaReduceThisModule = find (\ca -> getIgnoreHintText etaReduceHintName == (ca ^.L.title)) cas++        liftIO $ isJust applyAll @? "There is Apply all hints code action"+        liftIO $ isJust redId @? "There is Redundant id code action"+        liftIO $ isJust redEta @? "There is Eta reduce code action"+        liftIO $ isJust ignoreRedundantIdInThisModule @? "There is ignore Redundant id code action"+        liftIO $ isJust ignoreEtaReduceThisModule @? "There is ignore Eta reduce code action"++        executeCodeAction (fromJust redId)++        contents <- skipManyTill anyMessage $ getDocumentEdit doc+        liftIO $ contents @?= "main = undefined\nfoo x = x\n"++    , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do+        doc <- openDoc "Base.hs" "haskell"++        _ <- waitForDiagnosticsFromSource doc "hlint"++        cars <- getAllCodeActions doc+        etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"]++        executeCommand etaReduce++        contents <- skipManyTill anyMessage $ getDocumentEdit doc+        liftIO $ contents @?= "main = undefined\nfoo = id\n"++    , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do+        doc <- openDoc "FixityUse.hs" "haskell"+        expectNoMoreDiagnostics 3 doc "hlint"++    , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do+        doc <- openDoc "Base.hs" "haskell"+        testHlintDiagnostics doc++        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)+                                                         .+ #rangeLength .== Nothing+                                                         .+ #text .== "x"+        changeDoc doc [change]+        expectNoMoreDiagnostics 3 doc "hlint"++        let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)+                                                          .+ #rangeLength .== Nothing+                                                          .+ #text .== "id x"++        changeDoc doc [change']+        testHlintDiagnostics doc++    , testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession "cpp" $ do+        doc <- openDoc "CppCond.hs" "haskell"+        testHlintDiagnostics doc++    , knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $+      testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do+        doc <- openDoc "CppCond.hs" "haskell"+        testHlintDiagnostics doc++    , testCase "[#554] hlint diagnostics works with CPP via -XCPP argument and flag via #include header" $ runHlintSession "cpp" $ do+        doc <- openDoc "CppHeader.hs" "haskell"+        testHlintDiagnostics doc++    , testCase "[#590] apply-refact works with -XLambdaCase argument" $ runHlintSession "lambdacase" $ do+        testRefactor "LambdaCase.hs" "Redundant bracket"+            expectedLambdaCase++    , testCase "[#1242] apply-refact works with -XTypeApplications argument" $ runHlintSession "typeapps" $ do+        testRefactor "TypeApplication.hs" "Redundant bracket"+            expectedTypeApp++    , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do+        testRefactor "LambdaCase.hs" "Redundant bracket"+            ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)++    , expectFailBecause "apply-refact doesn't work with cpp" $+      testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do+        testRefactor "CppCond.hs" "Redundant bracket"+            expectedCPP++    , expectFailBecause "apply-refact doesn't work with cpp" $+      testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do+        testRefactor "CppCond.hs" "Redundant bracket"+            ("{-# LANGUAGE CPP #-}" : expectedCPP)++    , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do+        doc <- openDoc "CamelCase.hs" "haskell"+        expectNoMoreDiagnostics 3 doc "hlint"++    , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do+        doc <- openDoc "IgnoreAnn.hs" "haskell"+        expectNoMoreDiagnostics 3 doc "hlint"++    , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do+        doc <- openDoc "IgnoreAnnHlint.hs" "haskell"+        expectNoMoreDiagnostics 3 doc "hlint"++    , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do+        testRefactor "Comments.hs" "Redundant bracket" expectedComments++    , testCase "[#2290] apply all hints works with a trailing comment" $ runHlintSession "" $ do+        testRefactor "TwoHintsAndComment.hs" "Apply all hints" expectedComments2++    , testCase "applyAll is shown only when there is at least one diagnostic in range" $  runHlintSession "" $ do+        doc <- openDoc "TwoHints.hs" "haskell"+        _ <- waitForDiagnosticsFromSource doc "hlint"++        firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0)+        secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0)+        thirdLine <- map fromAction <$> getCodeActions doc (mkRange 2 0 2 0)+        multiLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 2 0)++        let hasApplyAll = isJust . find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title))++        liftIO $ hasApplyAll firstLine @? "Missing apply all code action"+        liftIO $ hasApplyAll secondLine @? "Missing apply all code action"+        liftIO $ not (hasApplyAll thirdLine) @? "Unexpected apply all code action"+        liftIO $ hasApplyAll multiLine @? "Missing apply all code action"++    , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do+        doc <- openDoc "UnusedExtension.hs" "haskell"+        diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint"++        liftIO $ do+            length diags @?= 1+            unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma")++    , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do+        doc <- openDoc "PatternKeyword.hs" "haskell"++        waitForAllProgressDone+        -- hlint will report a parse error if PatternSynonyms is enabled+        expectNoMoreDiagnostics 3 doc "hlint"+    , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do+        doc <- openDoc "StrictData.hs" "haskell"++        waitForAllProgressDone++        expectNoMoreDiagnostics 3 doc "hlint"+    ]+    where+        testRefactor file caTitle expected = do+            doc <- openDoc file "haskell"+            testHlintDiagnostics doc++            cas <- map fromAction <$> getAllCodeActions doc+            let ca = find (\ca -> caTitle `T.isInfixOf` (ca ^. L.title)) cas+            liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action")++            executeCodeAction (fromJust ca)++            contents <- skipManyTill anyMessage $ getDocumentEdit doc+            liftIO $ contents @?= T.unlines expected++        expectedLambdaCase = [ "module LambdaCase where", ""+                             , "f = \\case \"true\" -> True"+                             , "          _ -> False"+                             ]+        expectedCPP =        [ "module CppCond where", ""+                             , "#ifdef FLAG"+                             , "f = 1"+                             , "#else"+                             , "g = 2"+                             , "#endif", ""+                             ]+        expectedComments =  [ "-- comment before header"+                             , "module Comments where", ""+                             , "{-# standalone annotation #-}", ""+                             , "-- standalone comment", ""+                             , "-- | haddock comment"+                             , "f = {- inline comment -} {- inline comment inside refactored code -}1 -- ending comment", ""+                             , "-- final comment"+                             ]+        expectedComments2 =  [ "module TwoHintsAndComment where"+                             , "biggest = foldr1 max -- the line above will show two hlint hints, \"eta reduce\" and \"use maximum\""+                             ]+        expectedTypeApp =    [ "module TypeApplication where", ""+                             , "a = id @Int 1"+                             ]+++configTests :: TestTree+configTests = testGroup "hlint plugin config" [++    testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do+        setIgnoringConfigurationRequests False+        enableHlint++        doc <- openDoc "Base.hs" "haskell"+        testHlintDiagnostics doc++        disableHlint++        diags' <- waitForDiagnosticsFrom doc++        liftIO $ noHlintDiagnostics diags'++    , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do+        setIgnoringConfigurationRequests False+        enableHlint++        doc <- openDoc "Base.hs" "haskell"+        testHlintDiagnostics doc++        let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"]+        setHlsConfig config'++        diags' <- waitForDiagnosticsFrom doc++        liftIO $ noHlintDiagnostics diags'++    , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do+        setIgnoringConfigurationRequests False+        enableHlint++        doc <- openDoc "Generalise.hs" "haskell"++        expectNoMoreDiagnostics 3 doc "hlint"++        let config' = hlintConfigWithFlags ["--with-group=generalise"]+        setHlsConfig config'++        diags' <- waitForDiagnosticsFromSource doc "hlint"+        d <- liftIO $ inspectDiagnostic diags' ["Use <>"]++        liftIO $ do+            length diags' @?= 1+            d ^. L.range @?= Range (Position 1 10) (Position 1 21)+            d ^. L.severity @?= Just DiagnosticSeverity_Information+    ]++testDir :: FilePath+testDir = "plugins/hls-hlint-plugin/test/testdata"++runHlintSession :: FilePath -> Session a -> IO a+runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir </> subdir)++noHlintDiagnostics :: [Diagnostic] -> Assertion+noHlintDiagnostics diags =+    Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"++testHlintDiagnostics :: TextDocumentIdentifier -> Session ()+testHlintDiagnostics doc = do+    diags <- waitForDiagnosticsFromSource doc "hlint"+    liftIO $ length diags > 0 @? "There are hlint diagnostics"++hlintConfigWithFlags :: [T.Text] -> Config+hlintConfigWithFlags flags =+  def+    { Plugin.plugins = Map.fromList [("hlint",+        def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object ["flags" .= flags] }+    )] }+  where+    unObject (Object obj) = obj+    unObject _            = undefined++enableHlint :: Session ()+enableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = True }) ] }++disableHlint :: Session ()+disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = False }) ] }++-- We have two main code paths in the plugin depending on how hlint interacts with ghc:+-- * One when hlint uses ghc-lib (all ghc versions but the last version supported by hlint)+-- * Another one when hlint uses directly ghc (only one version, which not have to be the last version supported by ghcide)+-- As we always are using ghc through ghcide the code to get the ghc parsed AST differs+-- So the issues and bugs usually only affects to one code path or the other.+-- Although a given hlint version supports one direct ghc, we could use several versions of hlint+-- each one supporting a different ghc version. It should be a temporary situation though.+knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree+knownBrokenForHlintOnGhcLib = expectFailBecause++-- 1's based+data Point = Point {+  line   :: !Int,+  column :: !Int+}++pointToRange :: Point -> Range+pointToRange Point {..}+  | line <- fromIntegral $ subtract 1 line+  , column <- fromIntegral $ subtract 1 column =+      Range (Position line column) (Position line $ column + 1)++getCodeActionTitle :: (Command |? CodeAction) -> Maybe T.Text+getCodeActionTitle commandOrCodeAction+  | InR CodeAction {_title} <- commandOrCodeAction = Just _title+  | otherwise = Nothing++makeCodeActionNotFoundAtString :: Point -> String+makeCodeActionNotFoundAtString Point {..} =+  "CodeAction not found at line: " <> show line <> ", column: " <> show column++ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+ignoreHintGoldenTest testCaseName goldenFilename point hintName =+  goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName)++applyHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+applyHintGoldenTest testCaseName goldenFilename point hintName = do+  goldenTest testCaseName goldenFilename point (getApplyHintText hintName)++goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+goldenTest testCaseName goldenFilename point hintText =+  setupGoldenHlintTest testCaseName goldenFilename $ \document -> do+    _ <- waitForDiagnosticsFromSource document "hlint"+    actions <- getCodeActions document $ pointToRange point+    case find ((== Just hintText) . getCodeActionTitle) actions of+      Just (InR codeAction) -> do+        executeCodeAction codeAction+        when (isJust (codeAction ^. L.command)) $+          void $ skipManyTill anyMessage $ getDocumentEdit document+      _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point++setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+setupGoldenHlintTest testName path =+  goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs"++ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName =+  goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName)++applyHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do+  goldenResolveTest testCaseName goldenFilename point (getApplyHintText hintName)++goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree+goldenResolveTest testCaseName goldenFilename point hintText =+  setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do+    _ <- waitForDiagnosticsFromSource document "hlint"+    actions <- getAndResolveCodeActions document $ pointToRange point+    case find ((== Just hintText) . getCodeActionTitle) actions of+      Just (InR codeAction) -> executeCodeAction codeAction+      _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point++setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+setupGoldenHlintResolveTest testName path =+  goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs"
+ plugins/hls-hlint-plugin/test/testdata/Base.hs view
@@ -0,0 +1,2 @@+main = undefined+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/Comments.hs view
@@ -0,0 +1,11 @@+-- comment before header+module Comments where++{-# standalone annotation #-}++-- standalone comment++-- | haddock comment+f = {- inline comment -} ({- inline comment inside refactored code -}1) -- ending comment++-- final comment
+ plugins/hls-hlint-plugin/test/testdata/CppCond.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+module CppCond where++#ifdef FLAG+f = (1)+#else+g = 2+#endif
+ plugins/hls-hlint-plugin/test/testdata/Generalise.hs view
@@ -0,0 +1,2 @@+main = undefined+foo x y = [x, x] ++ y
+ plugins/hls-hlint-plugin/test/testdata/IgnoreAnn.hs view
@@ -0,0 +1,5 @@+module IgnoreAnn where++{-# ANN module "HLint: ignore Redundant bracket" #-}+f = (1)+
+ plugins/hls-hlint-plugin/test/testdata/IgnoreAnnHlint.hs view
@@ -0,0 +1,7 @@+module IgnoreHlintAnn where++{- HLINT ignore "Redundant bracket" -}+f = (1)++{-# HLINT ignore "Use camelCase" #-}+camel_case = undefined
+ plugins/hls-hlint-plugin/test/testdata/LambdaCase.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE LambdaCase #-}+module LambdaCase where++f = \case "true" -> (True)+          _ -> False
+ plugins/hls-hlint-plugin/test/testdata/PatternKeyword.hs view
@@ -0,0 +1,3 @@+module Foo (pattern) where++pattern = 42
+ plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs view
@@ -0,0 +1,6 @@+module RightToLeftFixities where+import Data.List (sortOn)+import Control.Arrow ((&&&))+import Data.Ord (Down(Down))+functionB :: [String] -> [(Char,Int)]+functionB = sortOn (Down . snd) . map (head &&& length) . id
+ plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs view
@@ -0,0 +1,6 @@+module RightToLeftFixities where+import Data.List (sortOn)+import Control.Arrow ((&&&))+import Data.Ord (Down(Down))+functionB :: [String] -> [(Char,Int)]+functionB = reverse . sortOn snd . map (head &&& length) . id
+ plugins/hls-hlint-plugin/test/testdata/StrictData.hs view
@@ -0,0 +1,2 @@+{-# LANGUAGE Strict #-}+f ~x = x
+ plugins/hls-hlint-plugin/test/testdata/TwoHints.hs view
@@ -0,0 +1,2 @@+f = (1)+g = (1)
+ plugins/hls-hlint-plugin/test/testdata/TwoHintsAndComment.hs view
@@ -0,0 +1,2 @@+module TwoHintsAndComment where+biggest items = foldr1 max items -- the line above will show two hlint hints, "eta reduce" and "use maximum"
+ plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Eta reduce" #-}+module UnrecognizedPragmasOff where+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+module UnrecognizedPragmasOff where+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wunrecognised-pragmas #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Eta reduce" #-}+module UnrecognizedPragmasOn where+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -Wunrecognised-pragmas #-}+module UnrecognizedPragmasOn where+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/cpp/CppCond.hs view
@@ -0,0 +1,7 @@+module ApplyRefact3 where++#ifdef FLAG+f = (1)+#else+g = 2+#endif
+ plugins/hls-hlint-plugin/test/testdata/cpp/CppHeader.hs view
@@ -0,0 +1,9 @@+module CppHeader where++#include "test.h"++#ifdef TEST+f = (1)+#else+f = 1+#endif
+ plugins/hls-hlint-plugin/test/testdata/cpp/hie.yaml view
@@ -0,0 +1,7 @@+cradle:+  direct:+    arguments:+      - "-XCPP"+      - "-DFLAG"+      - "CppCond"+      - "CppHeader"
+ plugins/hls-hlint-plugin/test/testdata/fixity/FixityDef.hs view
@@ -0,0 +1,5 @@+module FixityDef where++infixl 3 <!>+(<!>) :: Maybe a -> Maybe (Maybe b) -> Maybe String+(<!>) a b = Nothing
+ plugins/hls-hlint-plugin/test/testdata/fixity/FixityUse.hs view
@@ -0,0 +1,6 @@+module FixityUse where++import FixityDef++foo :: Char -> Maybe Int -> Maybe String+foo c mInt = show <$> mInt <!> pure <$> Just c
+ plugins/hls-hlint-plugin/test/testdata/fixity/hie.yaml view
@@ -0,0 +1,6 @@+cradle:+  direct:+    arguments:+      - "FixityDef"+      - "FixityUse"+
+ plugins/hls-hlint-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,16 @@+cradle:+  direct:+    arguments:+      - "-DFLAG"+      - "-Wno-unrecognised-pragmas"+      - "Base"+      - "Comments"+      - "CppCond"+      - "Generalise"+      - "IgnoreAnn"+      - "IgnoreAnnHlint"+      - "LambdaCase"+      - "TwoHints"+      - "PatternKeyword"+      - "StrictData"+      - "TwoHintsAndComment"
+ plugins/hls-hlint-plugin/test/testdata/ignore/CamelCase.hs view
@@ -0,0 +1,5 @@+module CamelCase where++f = (1)++camel_case = undefined
+ plugins/hls-hlint-plugin/test/testdata/ignore/hie.yaml view
@@ -0,0 +1,4 @@+cradle:+  direct:+    arguments:+      - "CamelCase"
+ plugins/hls-hlint-plugin/test/testdata/lambdacase/LambdaCase.hs view
@@ -0,0 +1,4 @@+module LambdaCase where++f = \case "true" -> (True)+          _ -> False
+ plugins/hls-hlint-plugin/test/testdata/lambdacase/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments:+      - "-XLambdaCase"+      - "LambdaCase"
+ plugins/hls-hlint-plugin/test/testdata/test-hlint-config.yaml view
@@ -0,0 +1,1 @@+- ignore: { name: Eta reduce }
+ plugins/hls-hlint-plugin/test/testdata/typeapps/TypeApplication.hs view
@@ -0,0 +1,3 @@+module TypeApplication where++a = (id @Int 1)
+ plugins/hls-hlint-plugin/test/testdata/typeapps/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments:+      - "-XTypeApplications"+      - "TypeApplications"
+ plugins/hls-hlint-plugin/test/testdata/unusedext/UnusedExtension.hs view
@@ -0,0 +1,1 @@+{-# LANGUAGE BangPatterns #-}
+ plugins/hls-hlint-plugin/test/testdata/unusedext/hie.yaml view
@@ -0,0 +1,4 @@+cradle:+  direct:+    arguments:+      - "UnusedExtension"
+ plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}++{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults #-}++{- | Keep the module name in sync with its file path.++Provide CodeLenses to:+* Add a module header ("module /moduleName/ where") to empty Haskell files+* Fix the module name if incorrect+-}+module Ide.Plugin.ModuleName (+    descriptor,+    Log,+) where++import           Control.Monad                        (forM_, void)+import           Control.Monad.IO.Class               (liftIO)+import           Control.Monad.Trans.Class            (lift)+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Maybe+import           Data.Aeson                           (toJSON)+import           Data.Char                            (isLower, isUpper)+import           Data.List                            (intercalate, minimumBy,+                                                       stripPrefix, uncons)+import qualified Data.List.NonEmpty                   as NE+import qualified Data.Map                             as Map+import           Data.Maybe                           (mapMaybe)+import           Data.Ord                             (comparing)+import           Data.String                          (IsString)+import qualified Data.Text                            as T+import           Development.IDE                      (GetParsedModule (GetParsedModule),+                                                       GhcSession (GhcSession),+                                                       IdeState, Pretty,+                                                       Priority (Debug),+                                                       Recorder, WithPriority,+                                                       colon, evalGhcEnv,+                                                       hscEnvWithImportPaths,+                                                       logWith,+                                                       realSrcSpanToRange,+                                                       runAction, useWithStale,+                                                       (<+>))+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (toCurrentRange)+import           Development.IDE.GHC.Compat           (GenLocated (L),+                                                       getSessionDynFlags,+                                                       hsmodName, importPaths,+                                                       locA, moduleNameString,+                                                       pattern RealSrcSpan,+                                                       pm_parsed_source, unLoc)+import           Ide.Logger                           (Pretty (..))+import           Ide.Plugin.Error+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server+import           Language.LSP.VFS                     (virtualFileText)+import           System.Directory                     (makeAbsolute)+import           System.FilePath                      (dropExtension, normalise,+                                                       pathSeparator,+                                                       splitDirectories,+                                                       takeFileName)++-- |Plugin descriptor+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+    (defaultPluginDescriptor plId "Provides a code action to alter the module name if it is wrong")+        { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (codeLens recorder)+        , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)]+        }++updateModuleNameCommand :: IsString p => p+updateModuleNameCommand = "updateModuleName"++-- | Generate code lenses+codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens+codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do+  res <- action recorder state uri+  pure $ InL (asCodeLens  <$> res)+  where+    asCodeLens :: Action -> CodeLens+    asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing+      where+        cmd = mkLspCommand pluginId updateModuleNameCommand aTitle (Just [toJSON aUri])++-- | (Quasi) Idempotent command execution: recalculate action to execute on command request+command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri+command recorder state _ uri = do+  actMaybe <- action recorder state uri+  forM_ actMaybe $ \Replace{..} ->+    let+      -- | Convert an Action to the corresponding edit operation+      edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing+    in+      void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ()))+  pure $ InR Null++-- | A source code change+data Action = Replace+  { aUri   :: Uri+  , aRange :: Range+  , aTitle :: T.Text+  , aCode  :: T.Text+  }+  deriving (Show)++-- | Required action (that can be converted to either CodeLenses or CodeActions)+action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]+action recorder state uri = do+    nfp <- getNormalizedFilePathE  uri+    fp <- uriToFilePathE uri++    contents <- lift . getVirtualFile $ toNormalizedUri uri+    let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents++    correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp+    logWith recorder Debug (CorrectNames correctNames)+    let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames+    logWith recorder Debug (BestName bestName)++    statedNameMaybe <- liftIO $ codeModuleName state nfp+    logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe)+    case (bestName, statedNameMaybe) of+      (Just bestName, Just (nameRange, statedName))+        | statedName `notElem` correctNames ->+            pure [Replace uri nameRange ("Set module name to " <> bestName) bestName]+      (Just bestName, Nothing)+        | emptyModule ->+            let code = "module " <> bestName <> " where\n"+            in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code]+      _ -> pure []++-- | Possible module names, as derived by the position of the module in the+-- source directories.  There may be more than one possible name, if the source+-- directories are nested inside each other.+pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text]+pathModuleNames recorder state normFilePath filePath+  | isLower . head $ takeFileName filePath = return ["Main"]+  | otherwise = do+      (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath+      srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags+      logWith recorder Debug (SrcPaths srcPaths)++      -- Append a `pathSeparator` to make the path looks like a directory,+      --   and then we can drop it uniformly.+      -- See https://github.com/haskell/haskell-language-server/pull/3092 for details.+      let paths = map (normalise . (<> pure pathSeparator)) srcPaths+      logWith recorder Debug (NormalisedPaths paths)++      mdlPath <- liftIO $ makeAbsolute filePath+      logWith recorder Debug (AbsoluteFilePath mdlPath)++      let suffixes = mapMaybe (`stripPrefix` mdlPath) paths+      pure (map moduleNameFrom suffixes)+  where+    moduleNameFrom =+      T.pack+        . intercalate "."+        -- Do not suggest names whose components start from a lower-case char,+        -- they are guaranteed to be malformed.+        . filter (maybe False (isUpper . fst) . uncons)+        . splitDirectories+        . dropExtension++-- | The module name, as stated in the module+codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text))+codeModuleName state nfp = runMaybeT $ do+  (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp+  L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm+  range <- MaybeT . pure $ toCurrentRange mp (realSrcSpanToRange l)+  pure (range, T.pack $ moduleNameString m)++data Log =+    CorrectNames [T.Text]+  | BestName (Maybe T.Text)+  | ModuleName (Maybe T.Text)+  | SrcPaths [FilePath]+  | NormalisedPaths [FilePath]+  | AbsoluteFilePath FilePath+  deriving Show++instance Pretty Log where+  pretty log = "ModuleName." <> case log of+    CorrectNames log     -> "CorrectNames" <> colon <+> pretty log+    BestName log         -> "BestName" <> colon <+> pretty log+    ModuleName log       -> "StatedNameMaybe" <> colon <+> pretty log+    SrcPaths log         -> "SrcPaths" <> colon <+> pretty log+    NormalisedPaths log  -> "NormalisedPaths" <> colon <+> pretty log+    AbsoluteFilePath log -> "AbsoluteFilePath" <> colon <+> pretty log
+ plugins/hls-module-name-plugin/test/Main.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+module Main+  ( main+  ) where++import           Control.Monad         (void)+import qualified Ide.Plugin.ModuleName as ModuleName+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++moduleNamePlugin :: PluginTestDescriptor ModuleName.Log+moduleNamePlugin = mkPluginTestDescriptor ModuleName.descriptor "moduleName"++tests :: TestTree+tests =+  testGroup "moduleName"+  [ goldenWithModuleName "Add module header to empty module" "TEmptyModule" $ \doc -> do+      [CodeLens { _command = Just c }] <- getCodeLenses doc+      executeCommand c+      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)++  , goldenWithModuleName "Fix wrong module name" "TWrongModuleName" $ \doc -> do+      [CodeLens { _command = Just c }] <- getCodeLenses doc+      executeCommand c+      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)++  , goldenWithModuleName "Must infer module name as Main, if the file name starts with a lowercase" "mainlike" $ \doc -> do+      [CodeLens { _command = Just c }] <- getCodeLenses doc+      executeCommand c+      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)++  , goldenWithModuleName "Fix wrong module name in nested directory" "subdir/TWrongModuleName" $ \doc -> do+      [CodeLens { _command = Just c }] <- getCodeLenses doc+      executeCommand c+      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+  , testCase "Should not show code lens if the module name is correct" $+      runSessionWithServer def moduleNamePlugin testDataDir $ do+        doc <- openDoc "CorrectName.hs" "haskell"+        lenses <- getCodeLenses doc+        liftIO $ lenses @?= []+        closeDoc doc+  -- https://github.com/haskell/haskell-language-server/issues/3047+  , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do+      [CodeLens { _command = Just c }] <- getCodeLenses doc+      executeCommand c+      void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+  , testCase "Keep stale lens even if parse failed" $ do+      runSessionWithServer def moduleNamePlugin testDataDir $ do+        doc <- openDoc "Stale.hs" "haskell"+        oldLens <- getCodeLenses doc+        let edit = TextEdit (mkRange 1 0 1 0) "f ="+        _ <- applyEdit doc edit+        newLens <- getCodeLenses doc+        liftIO $ newLens @?= oldLens+        closeDoc doc+  ]++goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithModuleName title path = goldenWithHaskellDoc def moduleNamePlugin title testDataDir path "expected" "hs"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-module-name-plugin" </> "test" </> "testdata"
+ plugins/hls-module-name-plugin/test/testdata/CorrectName.hs view
@@ -0,0 +1,1 @@+module CorrectName where
+ plugins/hls-module-name-plugin/test/testdata/Stale.hs view
@@ -0,0 +1,1 @@+module Foo where
+ plugins/hls-module-name-plugin/test/testdata/TEmptyModule.expected.hs view
@@ -0,0 +1,3 @@+module TEmptyModule where++
+ plugins/hls-module-name-plugin/test/testdata/TEmptyModule.hs view
@@ -0,0 +1,2 @@++
+ plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.expected.hs view
@@ -0,0 +1,7 @@+module TWrongModuleName+  ( x+  )+where++x :: Integer+x = 11
+ plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.hs view
@@ -0,0 +1,7 @@+module BadName+  ( x+  )+where++x :: Integer+x = 11
+ plugins/hls-module-name-plugin/test/testdata/cabal.project view
@@ -0,0 +1,1 @@+packages: ./canonicalize
+ plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs view
@@ -0,0 +1,1 @@+module Lib.A where
+ plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs view
+ plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal view
@@ -0,0 +1,7 @@+cabal-version: 2.4+name: canonicalize+version: 0.1.0.0++library+  build-depends: base+  hs-source-dirs: ./
+ plugins/hls-module-name-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,17 @@+cradle:+  multi:+    - path: "./"+      config:+        cradle:+          direct:+            arguments:+              - "-isubdir"+              - "TEmptyModule"+              - "TWrongModuleName"+              - "CorrectName"+    - path: "./canonicalize"+      config:+        cradle:+          cabal:+            - path: "./"+              component: "lib:canonicalize"
+ plugins/hls-module-name-plugin/test/testdata/mainlike.expected.hs view
@@ -0,0 +1,1 @@+module Main where
+ plugins/hls-module-name-plugin/test/testdata/mainlike.hs view
+ plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.expected.hs view
@@ -0,0 +1,7 @@+module TWrongModuleName+  ( x+  )+where++x :: Integer+x = 11
+ plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.hs view
@@ -0,0 +1,7 @@+module BadName+  ( x+  )+where++x :: Integer+x = 11
+ plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.Ormolu+  ( descriptor+  , provider+  , LogEvent+  )+where++import           Control.Exception               (Handler (..), IOException,+                                                  SomeException (..), catches,+                                                  handle)+import           Control.Monad.Except            (runExceptT, throwError)+import           Control.Monad.Extra+import           Control.Monad.Trans+import           Control.Monad.Trans.Except      (ExceptT (..), mapExceptT)+import           Data.Functor                    ((<&>))+import           Data.List                       (intercalate)+import           Data.Maybe                      (catMaybes)+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Development.IDE                 hiding (pluginHandlers)+import           Development.IDE.GHC.Compat      (hsc_dflags, moduleNameString)+import qualified Development.IDE.GHC.Compat      as D+import qualified Development.IDE.GHC.Compat.Util as S+import           GHC.LanguageExtensions.Type+import           Ide.Plugin.Error                (PluginError (PluginInternalError))+import           Ide.Plugin.Properties+import           Ide.PluginUtils+import           Ide.Types                       hiding (Config)+import qualified Ide.Types                       as Types+import           Language.LSP.Protocol.Types+import           Language.LSP.Server             hiding (defaultConfig)+import           Ormolu+import           System.Exit+import           System.FilePath+import           System.Process.Run              (cwd, proc)+import           System.Process.Text             (readCreateProcessWithExitCode)+import           Text.Read                       (readMaybe)++-- ---------------------------------------------------------------------++descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  (defaultPluginDescriptor plId desc)+    { pluginHandlers = mkFormattingHandlers $ provider recorder plId,+      pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}+    }+  where+    desc = "Provides formatting of Haskell files via ormolu. Built with ormolu-" <> VERSION_ormolu++properties :: Properties '[ 'PropertyKey "external" 'TBoolean]+properties =+  emptyProperties+    & defineBooleanProperty+      #external+      "Call out to an external \"ormolu\" executable, rather than using the bundled library"+      False++-- ---------------------------------------------------------------------++provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState+provider recorder plId ideState token typ contents fp _ = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do+  fileOpts <-+      maybe [] (fromDyn . hsc_dflags . hscEnv)+          <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp)+  useCLI <- liftIO $ runAction "Ormolu" ideState $ usePropertyAction #external plId properties++  if useCLI+      then mapExceptT liftIO $ ExceptT+           $ handle @IOException+          (pure . Left . PluginInternalError . T.pack . show)+           $ runExceptT $ cliHandler fileOpts+      else do+          logWith recorder Debug $ LogCompiledInVersion VERSION_ormolu++          let+            fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text)+            fmt cont conf = flip catches handlers $ do+#if MIN_VERSION_ormolu(0,5,3)+              cabalInfo <- getCabalInfoForSourceFile fp' <&> \case+                CabalNotFound                -> Nothing+                CabalDidNotMention cabalInfo -> Just cabalInfo+                CabalFound cabalInfo         -> Just cabalInfo+#if MIN_VERSION_ormolu(0,7,0)+              (fixityOverrides, moduleReexports) <- getDotOrmoluForSourceFile fp'+              let conf' = refineConfig ModuleSource cabalInfo (Just fixityOverrides) (Just moduleReexports) conf+#else+              fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo+              let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf+#endif+              let cont' = cont+#else+              let conf' = conf+                  cont' = T.unpack cont+#endif+              Right <$> ormolu conf' fp' cont'+            handlers =+              [ Handler $ pure . Left . SomeException @OrmoluException+              , Handler $ pure . Left . SomeException @IOException+              ]++          res <- liftIO $ fmt contents defaultConfig { cfgDynOptions = map DynOption fileOpts, cfgRegion = region }+          ret res+ where+   fp' = fromNormalizedFilePath fp++   region :: RegionIndices+   region = case typ of+       FormatText ->+           RegionIndices Nothing Nothing+       FormatRange (Range (Position sl _) (Position el _)) ->+           RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1)++   title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)++   ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null)+   ret (Left err)  = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err+   ret (Right new) = pure $ InL $ makeDiffTextEdit contents new++   fromDyn :: D.DynFlags -> [String]+   fromDyn df =+     let+       pp =+         let p = D.sPgm_F $ D.settings df+         in  ["-pgmF=" <> p | not (null p)]+       pm = ("-fplugin=" <>) . moduleNameString <$> D.pluginModNames df+       ex = showExtension <$> S.toList (D.extensionFlags df)+     in pp <> pm <> ex++   cliHandler :: [String] -> ExceptT PluginError IO ([TextEdit] |? Null)+   cliHandler fileOpts = do+       CLIVersionInfo{noCabal} <- do -- check Ormolu version so that we know which flags to use+           (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc "ormolu" ["--version"] ) ""+           let version = do+                   guard $ exitCode == ExitSuccess+                   "ormolu" : v : _ <- pure $ T.words out+                   traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v+           case version of+               Just v -> do+                   logWith recorder Debug $ LogExternalVersion v+                   pure CLIVersionInfo+                       { noCabal = v >= [0, 7]+                       }+               Nothing -> do+                   logWith recorder Debug $ LogExternalVersion []+                   logWith recorder Warning $ NoVersion out+                   pure CLIVersionInfo+                       { noCabal = True+                       }+       (exitCode, out, err) <- do -- run Ormolu+           let commandArgs = map ("-o" <>) fileOpts+                       -- "The --stdin-input-file option is necessary when using input from+                       -- stdin and accounting for .cabal files" as per Ormolu documentation+                       <> (if noCabal then ["--no-cabal"] else ["--stdin-input-file", fp'])+                       <> catMaybes+                           [ ("--start-line=" <>) . show <$> regionStartLine region+                           , ("--end-line=" <>) . show <$> regionEndLine region+                           ]+               cwd = takeDirectory fp'+           logWith recorder Debug $ LogOrmoluCommand commandArgs cwd+           liftIO $ readCreateProcessWithExitCode (proc "ormolu" commandArgs) {cwd = Just cwd} contents+       case exitCode of+           ExitSuccess -> do+               when (not $ T.null err) $ logWith recorder Debug $ StdErr err+               pure $ InL $ makeDiffTextEdit contents out+           ExitFailure n -> do+               logWith recorder Info $ StdErr err+               throwError $ PluginInternalError $ "Ormolu failed with exit code " <> T.pack (show n)++newtype CLIVersionInfo =   CLIVersionInfo+    { noCabal :: Bool+    }++data LogEvent+    = NoVersion Text+    | StdErr Text+    | LogCompiledInVersion String+    | LogExternalVersion [Int]+    | LogOrmoluCommand [String] FilePath+    deriving (Show)++instance Pretty LogEvent where+    pretty = \case+        NoVersion t -> "Couldn't get Ormolu version:" <> line <> indent 2 (pretty t)+        StdErr t -> "Ormolu stderr:" <> line <> indent 2 (pretty t)+        LogCompiledInVersion v -> "Using compiled in ormolu-" <> pretty v+        LogExternalVersion v ->+            "Using external ormolu"+            <> if null v then "" else "-"+            <> pretty (intercalate "." $ map show v)+        LogOrmoluCommand commandArgs cwd -> "Running: `ormolu " <> pretty (unwords commandArgs) <> "` in directory " <> pretty cwd++showExtension :: Extension -> String+showExtension Cpp   = "-XCPP"+showExtension other = "-X" ++ show other
+ plugins/hls-ormolu-plugin/test/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+module Main+  ( main+  ) where++import           Data.Aeson+import qualified Data.Aeson.KeyMap           as KM+import           Data.Functor+import           Ide.Plugin.Config+import qualified Ide.Plugin.Ormolu           as Ormolu+import           Language.LSP.Protocol.Types+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++ormoluPlugin :: PluginTestDescriptor Ormolu.LogEvent+ormoluPlugin = mkPluginTestDescriptor Ormolu.descriptor "ormolu"++tests :: TestTree+tests = testGroup "ormolu" $+    [False, True] <&> \cli ->+    testGroup (if cli then "cli" else "lib")+      [ goldenWithOrmolu cli "formats correctly" "Ormolu" "formatted" $ \doc -> do+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+      , goldenWithOrmolu cli "formats imports correctly" "Ormolu2" "formatted" $ \doc -> do+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+#if MIN_VERSION_ormolu(0,5,3)+      , goldenWithOrmolu cli "formats operators correctly" "Ormolu3" "formatted" $ \doc -> do+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)+#endif+      ]++goldenWithOrmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithOrmolu cli title path desc =+  goldenWithHaskellDocFormatter def ormoluPlugin "ormolu" conf title testDataDir path desc "hs"+ where+  conf = def{plcConfig = KM.fromList ["external" .= cli]}++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-ormolu-plugin" </> "test" </> "testdata"
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu.expected.hs view
@@ -0,0 +1,16 @@+module Ormolu where++import Data.Int+import Data.List+import Prelude++foo :: Int -> Int+foo 3 = 2+foo x = x++bar :: String -> IO String+bar s = do+  x <- return "hello"+  return "asdf"++data Baz = Baz {a :: Int, b :: String}
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu.formatted.hs view
@@ -0,0 +1,16 @@+module Ormolu where++import Data.Int+import Data.List+import Prelude++foo :: Int -> Int+foo 3 = 2+foo x = x++bar :: String -> IO String+bar s = do+  x <- return "hello"+  return "asdf"++data Baz = Baz {a :: Int, b :: String}
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu.hs view
@@ -0,0 +1,15 @@+module    Ormolu where+import Data.List++import Prelude+import Data.Int+foo   :: Int ->  Int+foo  3 = 2+foo    x  = x+bar   :: String ->   IO String+bar s =  do+      x <- return "hello"+      return "asdf"++data Baz = Baz { a :: Int, b :: String }+
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu2.expected.hs view
@@ -0,0 +1,5 @@+import Data.Bool+import Data.Char+import Data.Data+import Data.Either+import Data.Int
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu2.formatted.hs view
@@ -0,0 +1,5 @@+import Data.Bool+import Data.Char+import Data.Data+import Data.Either+import Data.Int
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu2.hs view
@@ -0,0 +1,5 @@+import Data.Char+import Data.Either+import Data.Int+import Data.Data+import Data.Bool
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu3.expected.hs view
@@ -0,0 +1,5 @@+foo :: String+foo =+  "a" .=? "b"+    <> "c" .=? "d"+    <> "e" .=? "f"
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu3.formatted.hs view
@@ -0,0 +1,5 @@+foo :: String+foo =+  "a" .=? "b"+    <> "c" .=? "d"+    <> "e" .=? "f"
+ plugins/hls-ormolu-plugin/test/testdata/Ormolu3.hs view
@@ -0,0 +1,3 @@+foo :: String+foo = "a" .=? "b"+    <> "c" .=? "d" <> "e" .=? "f"
+ plugins/hls-ormolu-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-ormolu-plugin/test/testdata/test.cabal view
@@ -0,0 +1,3 @@+cabal-version: 3.0+name: test+version: 0
+ plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE ViewPatterns      #-}+module Ide.Plugin.OverloadedRecordDot+  ( descriptor+  , Log+  ) where++-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin++import           Control.Lens                         ((^.))+import           Control.Monad                        (replicateM)+import           Control.Monad.IO.Class               (MonadIO, liftIO)+import           Control.Monad.Trans.Except           (ExceptT)+import           Data.Aeson                           (FromJSON, ToJSON, toJSON)+import           Data.Generics                        (GenericQ, everythingBut,+                                                       mkQ)+import qualified Data.IntMap.Strict                   as IntMap+import qualified Data.Map                             as Map+import           Data.Maybe                           (mapMaybe, maybeToList)+import           Data.Text                            (Text)+import           Data.Unique                          (hashUnique, newUnique)+import           Development.IDE                      (IdeState,+                                                       NormalizedFilePath,+                                                       Pretty (..), Range,+                                                       Recorder (..), Rules,+                                                       WithPriority (..),+                                                       realSrcSpanToRange)+import           Development.IDE.Core.RuleTypes       (TcModuleResult (..),+                                                       TypeCheck (..))+import           Development.IDE.Core.Shake           (define, useWithStale)+import qualified Development.IDE.Core.Shake           as Shake++#if __GLASGOW_HASKELL__ >= 903+import           Development.IDE.GHC.Compat           (HsExpr (HsRecSel))+#else+import           Development.IDE.GHC.Compat           (HsExpr (HsRecFld))+#endif++import           Control.DeepSeq                      (rwhnf)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (PositionMapping,+                                                       toCurrentRange)+import           Development.IDE.GHC.Compat           (Extension (OverloadedRecordDot),+                                                       GhcPass,+                                                       HsExpansion (HsExpanded),+                                                       HsExpr (HsApp, HsVar, OpApp, XExpr),+                                                       LHsExpr, Pass (..),+                                                       appPrec, dollarName,+                                                       getLoc, hs_valds,+                                                       parenthesizeHsExpr,+                                                       pattern RealSrcSpan,+                                                       unLoc)+import           Development.IDE.GHC.Util             (getExtensions,+                                                       printOutputable)+import           Development.IDE.Graph                (RuleResult)+import           Development.IDE.Graph.Classes        (Hashable, NFData (rnf))+import           Development.IDE.Spans.Pragmas        (NextPragmaInfo (..),+                                                       getFirstPragma,+                                                       insertNewPragma)+import           GHC.Generics                         (Generic)+import           Ide.Logger                           (Priority (..),+                                                       cmapWithPrio, logWith,+                                                       (<+>))+import           Ide.Plugin.Error                     (PluginError (..),+                                                       getNormalizedFilePathE,+                                                       handleMaybe)+import           Ide.Plugin.RangeMap                  (RangeMap)+import qualified Ide.Plugin.RangeMap                  as RangeMap+import           Ide.Plugin.Resolve                   (mkCodeActionHandlerWithResolve)+import           Ide.Types                            (PluginDescriptor (..),+                                                       PluginId (..),+                                                       PluginMethodHandler,+                                                       ResolveFunction,+                                                       defaultPluginDescriptor)+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message        (Method (..))+import           Language.LSP.Protocol.Types          (CodeAction (..),+                                                       CodeActionKind (CodeActionKind_RefactorRewrite),+                                                       CodeActionParams (..),+                                                       TextEdit (..), Uri (..),+                                                       WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),+                                                       type (|?) (..))++data Log+    = LogShake Shake.Log+    | LogCollectedRecordSelectors [RecordSelectorExpr]+    | forall a. (Pretty a) => LogResolve a++instance Pretty Log where+    pretty = \case+        LogShake shakeLog -> pretty shakeLog+        LogCollectedRecordSelectors recs -> "Collected record selectors:"+                                                <+> pretty recs+        LogResolve msg -> pretty msg++data CollectRecordSelectors = CollectRecordSelectors+                    deriving (Eq, Show, Generic)++instance Hashable CollectRecordSelectors+instance NFData CollectRecordSelectors++data CollectRecordSelectorsResult = CRSR+    { -- |We store everything in here that we need to create the unresolved+      -- codeAction: the range, an uniquely identifiable int, and the selector+      --selector expression  (HSExpr) that we use to generate the name+      records           :: RangeMap (Int, HsExpr (GhcPass 'Renamed))+      -- |This is for when we need to fully generate a textEdit. It contains the+      -- whole expression we are interested in indexed to the unique id we got+      -- from the previous field+    , recordInfos       :: IntMap.IntMap RecordSelectorExpr+    , enabledExtensions :: [Extension]+    }+    deriving (Generic)++instance NFData CollectRecordSelectorsResult++instance Show CollectRecordSelectorsResult where+    show _ = "<CollectRecordsResult>"++type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult++-- |Where we store our collected record selectors+data RecordSelectorExpr = RecordSelectorExpr+    { -- |The location of the matched expression+    location     :: Range,+    -- |The record selector, this is found in front of recordExpr, but get's+    -- placed after it when converted into record dot syntax+    selectorExpr :: LHsExpr (GhcPass 'Renamed),+    -- |The record expression. The only requirement is that it evaluates to a+    -- record in the end+    recordExpr   :: LHsExpr (GhcPass 'Renamed) }++instance Pretty RecordSelectorExpr where+    pretty (RecordSelectorExpr _ rs se) = pretty (printOutputable rs) <> ":"+                                            <+> pretty (printOutputable se)++instance NFData RecordSelectorExpr where+  rnf = rwhnf++-- |The data that is serialized and placed in the data field of resolvable+-- code actions+data ORDResolveData = ORDRD {+  -- |We need the uri to get shake results+  uri      :: Uri+  -- |The unique id that allows us to find the specific codeAction we want+, uniqueID :: Int+} deriving (Generic, Show)+instance ToJSON ORDResolveData+instance FromJSON ORDResolveData++descriptor :: Recorder (WithPriority Log) -> PluginId+                -> PluginDescriptor IdeState+descriptor recorder plId =+  let resolveRecorder = cmapWithPrio LogResolve recorder+      pluginHandler = mkCodeActionHandlerWithResolve resolveRecorder codeActionProvider resolveProvider+  in (defaultPluginDescriptor plId "Provides a code action to convert record selector usage to use overloaded record dot syntax")+    { pluginHandlers = pluginHandler+    , pluginRules = collectRecSelsRule recorder+    }++resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve+resolveProvider ideState plId ca uri (ORDRD _ int) =+  do+    nfp <- getNormalizedFilePathE uri+    CRSR _ crsDetails exts <- collectRecSelResult ideState nfp+    pragma <- getFirstPragma plId ideState nfp+    rse <- handleMaybe PluginStaleResolve $ IntMap.lookup int crsDetails+    pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma}++codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionProvider ideState _ (CodeActionParams _ _ caDocId caRange _) =+    do+        nfp <- getNormalizedFilePathE (caDocId ^. L.uri)+        CRSR crsMap _ exts <- collectRecSelResult ideState nfp+        let mkCodeAction (crsM, nse)  = InR CodeAction+                { -- We pass the record selector to the title function, so that+                  -- we can have the name of the record selector in the title of+                  -- the codeAction. This allows the user can easily distinguish+                  -- between the different codeActions when using nested record+                  -- selectors, the disadvantage is we need to print out the+                  -- name of the record selector which will decrease performance+                  _title = mkCodeActionTitle exts nse+                , _kind = Just CodeActionKind_RefactorRewrite+                , _diagnostics = Nothing+                , _isPreferred = Nothing+                , _disabled = Nothing+                , _edit = Nothing+                , _command = Nothing+                , _data_ = Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM+                }+            actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)+        pure $ InL actions+    where+    mkCodeActionTitle :: [Extension] -> HsExpr (GhcPass 'Renamed) -> Text+    mkCodeActionTitle exts se =+        if OverloadedRecordDot `elem` exts+            then title+            else title <> " (needs extension: OverloadedRecordDot)"+        where+            title = "Convert `" <> printOutputable se <> "` to record dot syntax"++mkWorkspaceEdit:: Uri -> RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit+mkWorkspaceEdit uri recSel exts pragma =+    Just $ WorkspaceEdit+    { _changes =+        Just (Map.singleton uri (convertRecordSelectors recSel : maybeToList pragmaEdit))+    , _documentChanges = Nothing+    , _changeAnnotations = Nothing}+    where pragmaEdit =+            if OverloadedRecordDot `elem` exts+            then Nothing+            else Just $ insertNewPragma pragma OverloadedRecordDot++collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()+collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $+    \CollectRecordSelectors nfp ->+        useWithStale TypeCheck nfp >>= \case+        -- `useWithStale` here allows us to be able to return codeActions even+        -- if the file does not typecheck. The disadvantage being that we+        -- sometimes will end up corrupting code. This is most obvious in that+        -- used code actions will continue to be presented, and when applied+        -- multiple times will almost always cause code corruption.+        Nothing -> pure ([], Nothing)+        Just (tmr, pm) -> do+            let -- We need the file's extensions to check whether we need to add+                -- the OverloadedRecordDot pragma+                exts = getEnabledExtensions tmr+                recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr)+            -- We are creating a list as long as our rec selectors of unique int s+            -- created by calling hashUnique on a Unique. The reason why we are+            -- extracting the ints is because they don't need any work to serialize.+            uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique)+            logWith recorder Debug (LogCollectedRecordSelectors recSels)+            let crsUniquesAndDetails =  zip uniques recSels+                -- We need the rangeMap to be able to filter by range later+                rangeAndUnique = toRangeAndUnique <$> crsUniquesAndDetails+                crsMap :: RangeMap (Int,  HsExpr (GhcPass 'Renamed))+                crsMap = RangeMap.fromList' rangeAndUnique+            pure ([], CRSR <$> Just crsMap <*> Just (IntMap.fromList crsUniquesAndDetails) <*> Just exts)+    where getEnabledExtensions :: TcModuleResult -> [Extension]+          getEnabledExtensions = getExtensions . tmrParsed+          getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]+          getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =+            collectRecordSelectors valBinds+          rewriteRange :: PositionMapping -> RecordSelectorExpr+                            -> Maybe RecordSelectorExpr+          rewriteRange pm recSel =+            case toCurrentRange pm (location recSel) of+                Just newLoc -> Just $ recSel{location = newLoc}+                Nothing     -> Nothing+          toRangeAndUnique (uid, RecordSelectorExpr l (unLoc -> se) _) = (l, (uid, se))++convertRecordSelectors :: RecordSelectorExpr ->  TextEdit+convertRecordSelectors RecordSelectorExpr{..} =+    TextEdit location $ convertRecSel selectorExpr recordExpr++-- |Converts a record selector expression into record dot syntax, currently we+-- are using printOutputable to do it. We are also letting GHC decide when to+-- parenthesize the record expression+convertRecSel :: LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> Text+convertRecSel se re = printOutputable (parenthesizeHsExpr appPrec re) <> "."+                        <> printOutputable se++collectRecordSelectors :: GenericQ [RecordSelectorExpr]+-- It's important that we use everthingBut here, because if we used everything+-- we would get duplicates for every case that occurs inside a HsExpanded+-- expression. Please see the test MultilineExpanded.hs+collectRecordSelectors = everythingBut (<>) (([], False) `mkQ` getRecSels)++-- |We want to return a list here, because on the occasion that we encounter a+-- HsExpanded expression, we want to return all the results from recursing on+-- one branch, which could be multiple matches. Again see MultilineExpanded.hs+getRecSels :: LHsExpr (GhcPass 'Renamed) -> ([RecordSelectorExpr], Bool)+-- When we stumble upon an occurrence of HsExpanded, we only want to follow one+-- branch. We do this here, by explicitly returning occurrences from traversing+-- the original branch, and returning True, which keeps syb from implicitly+-- continuing to traverse.+getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True)+#if __GLASGOW_HASKELL__ >= 903+-- applied record selection: "selector record" or "selector (record)" or+-- "selector selector2.record2"+getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) =+    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re+      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )+-- Record selection where the field is being applied with the "$" operator:+-- "selector $ record"+getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _)+                        (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName =+    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan')  se re+      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )+#else+getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) =+    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re+      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )+getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _)+                        (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName =+    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan')  se re+      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )+#endif+getRecSels _ = ([], False)++collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath+                        -> ExceptT PluginError m CollectRecordSelectorsResult+collectRecSelResult ideState =+    runActionE "overloadedRecordDot.collectRecordSelectors" ideState+        . useE CollectRecordSelectors+
+ plugins/hls-overloaded-record-dot-plugin/test/Main.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}++module Main ( main ) where++import           Data.Either                    (rights)+import qualified Data.Text                      as T+import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot+import           System.FilePath                ((</>))+import           Test.Hls++main :: IO ()+main =+  defaultTestRunner test++plugin :: PluginTestDescriptor OverloadedRecordDot.Log+plugin = mkPluginTestDescriptor OverloadedRecordDot.descriptor "overloaded-record-dot"++test :: TestTree+test = testGroup "overloaded-record-dot"+      (mkTest "Simple" "Simple" "name" 10 7 10 15+    <> mkTest "NoPragmaNeeded" "NoPragmaNeeded" "name" 11 7 11 15+    <> mkTest "NestedParens" "NestedParens" "name" 15 7 15 24+    <> mkTest "NestedDot" "NestedDot" "name" 17 7 17 22+    <> mkTest "NestedDollar" "NestedDollar" "name" 15 7 15 24+    <> mkTest "MultilineCase" "MultilineCase" "name" 10 7 12 15+    <> mkTest "Multiline" "Multiline" "name" 10 7 11 15+    <> mkTest "MultilineExpanded" "MultilineExpanded" "owner" 28 8 28 19)++mkTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> [TestTree]+mkTest title fp selectorName x1 y1 x2 y2 =+    [mkNoResolveTest (title <> " without resolve") fp selectorName x1 y1 x2 y2,+    mkResolveTest (title <> " with resolve") fp selectorName x1 y1 x2 y2]++mkNoResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree+mkNoResolveTest title fp selectorName x1 y1 x2 y2 =+  goldenWithHaskellAndCaps def codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do+    (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2+    executeCodeAction act++mkResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree+mkResolveTest title fp selectorName x1 y1 x2 y2 =+  goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do+    (act:_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2+    executeCodeAction act+++getExplicitFieldsActions+  :: TextDocumentIdentifier+  -> T.Text+  -> UInt -> UInt -> UInt -> UInt+  -> Session [CodeAction]+getExplicitFieldsActions doc selectorName x1 y1 x2 y2 =+  findExplicitFieldsAction selectorName <$> getCodeActions doc range+  where+    range = Range (Position x1 y1) (Position x2 y2)++getAndResolveExplicitFieldsActions+  :: TextDocumentIdentifier+  -> T.Text+  -> UInt -> UInt -> UInt -> UInt+  -> Session [CodeAction]+getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 = do+    findExplicitFieldsAction selectorName <$> getAndResolveCodeActions doc range+  where+    range = Range (Position x1 y1) (Position x2 y2)++findExplicitFieldsAction :: T.Text  -> [a |? CodeAction] -> [CodeAction]+findExplicitFieldsAction selectorName = filter (isExplicitFieldsCodeAction selectorName) . rights . map toEither++isExplicitFieldsCodeAction :: T.Text -> CodeAction -> Bool+isExplicitFieldsCodeAction selectorName CodeAction {_title} =+  ("Convert `" <> selectorName <> "` to record dot syntax") `T.isPrefixOf` _title++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-overloaded-record-dot-plugin" </> "test" </> "testdata"
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = man.name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs view
@@ -0,0 +1,12 @@+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = name+            man
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+  putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test ::  String+test = (case True of+   True -> man+   False -> man).name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs view
@@ -0,0 +1,13 @@+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+  putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test ::  String+test = name $ case True of+   True  -> man+   False -> man
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedRecordDot #-}++data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+  putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++home2 :: Building+home2 = Building {address = "No. 6 Beach Ave.", owner = man}++home3 :: Building+home3 = Building {address = "No. 12 Central Blvd.", owner = man}++n:: Int+n = 3++test :: String+test = (case n of+   0  -> owner home+   1 -> home2.owner+   2 -> owner home3+   _ -> man).name+
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedRecordDot #-}++data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+  putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++home2 :: Building+home2 = Building {address = "No. 6 Beach Ave.", owner = man}++home3 :: Building+home3 = Building {address = "No. 12 Central Blvd.", owner = man}++n:: Int+n = 3++test :: String+test = (case n of+   0  -> owner home+   1 -> owner home2+   2 -> owner home3+   _ -> man).name+
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = (owner home).name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs view
@@ -0,0 +1,16 @@+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = name $ owner home
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedRecordDot #-}++data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = home.owner.name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedRecordDot #-}++data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = name home.owner
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = (owner home).name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs view
@@ -0,0 +1,16 @@+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++data Building = Building {address :: String, owner :: Happy}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++home :: Building+home = Building {address = "No. 10 Privet Dr.", owner = man}++test :: String+test = name (owner home)
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = man.name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = name man
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedRecordDot #-}+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = man.name
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs view
@@ -0,0 +1,11 @@+data Happy = Happy {name :: String, age :: Int, happy :: Bool}++main :: IO ()+main = do+    putStrLn test++man :: Happy+man = Happy {name = "Happy", age = 1, happy = True}++test :: String+test = name man
+ plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: []}}
+ plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ViewPatterns          #-}++-- | Provides code actions to add missing pragmas (whenever GHC suggests to)+module Ide.Plugin.Pragmas+  ( suggestPragmaDescriptor+  , completionDescriptor+  , suggestDisableWarningDescriptor+  -- For testing+  , validPragmas+  , AppearWhere(..)+  ) where++import           Control.Lens                             hiding (List)+import           Control.Monad.IO.Class                   (MonadIO (liftIO))+import           Control.Monad.Trans.Class                (lift)+import           Data.Char                                (isAlphaNum)+import           Data.List.Extra                          (nubOrdOn)+import qualified Data.Map                                 as M+import           Data.Maybe                               (mapMaybe)+import qualified Data.Text                                as T+import           Development.IDE                          hiding (line)+import           Development.IDE.Core.Compile             (sourceParser,+                                                           sourceTypecheck)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.GHC.Compat+import           Development.IDE.Plugin.Completions       (ghcideCompletionsPluginPriority)+import           Development.IDE.Plugin.Completions.Logic (getCompletionPrefix)+import           Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))+import qualified Development.IDE.Spans.Pragmas            as Pragmas+import           Ide.Plugin.Error+import           Ide.Types+import qualified Language.LSP.Protocol.Lens               as L+import qualified Language.LSP.Protocol.Message            as LSP+import qualified Language.LSP.Protocol.Types              as LSP+import qualified Language.LSP.Server                      as LSP+import qualified Text.Fuzzy                               as Fuzzy++-- ---------------------------------------------------------------------++suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState+suggestPragmaDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to add missing LANGUAGE pragmas")+  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider+  , pluginPriority = defaultPluginPriority + 1000+  }++completionDescriptor :: PluginId -> PluginDescriptor IdeState+completionDescriptor plId = (defaultPluginDescriptor plId "Provides completion of LANGAUGE pragmas")+  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion+  , pluginPriority = ghcideCompletionsPluginPriority + 1+  }++suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState+suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to disable warnings")+  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider+    -- #3636 Suggestions to disable warnings should appear last.+  , pluginPriority = 0+  }++-- ---------------------------------------------------------------------+-- | Title and pragma+type PragmaEdit = (T.Text, Pragma)++data Pragma = LangExt T.Text | OptGHC T.Text+  deriving (Show, Eq, Ord)++suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+suggestPragmaProvider = mkCodeActionProvider suggest++suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning++mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+mkCodeActionProvider mkSuggest state _plId+  (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do+    normalizedFilePath <- getNormalizedFilePathE uri+    -- ghc session to get some dynflags even if module isn't parsed+    (hscEnv -> hsc_dflags -> sessionDynFlags, _) <-+      runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath+    (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath+    parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath+    let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule+        nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents+        pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags+    pure  $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits++++-- | Add a Pragma to the given URI at the top of the file.+-- It is assumed that the pragma name is a valid pragma,+-- thus, not validated.+pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction)+pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) =+  LSP.InR $ LSP.CodeAction title (Just LSP.CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing+  where+    render (OptGHC x)  = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n"+    render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n"+    pragmaInsertPosition = Position (fromIntegral nextPragmaLine) 0+    pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition+    -- workaround the fact that for some reason lsp-test applies text+    -- edits in reverse order than lsp (tried in both coc.nvim and vscode)+    textEdits =+      if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits+         , let LSP.TextEdit{ _range, _newText } = insertTextEdit ->+             [LSP.TextEdit _range (render p <> _newText), deleteTextEdit]+         | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)]++    edit =+      LSP.WorkspaceEdit+        (Just $ M.singleton uri textEdits)+        Nothing+        Nothing++suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]+suggest dflags diag =+  suggestAddPragma dflags diag++-- ---------------------------------------------------------------------++suggestDisableWarning :: Diagnostic -> [PragmaEdit]+suggestDisableWarning Diagnostic {_code}+  | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code+  , w `notElem` warningBlacklist =+    pure ("Disable \"" <> w <> "\" warnings", OptGHC w)+  | otherwise = []++-- Don't suggest disabling type errors as a solution to all type errors+warningBlacklist :: [T.Text]+warningBlacklist = ["deferred-type-errors"]++-- ---------------------------------------------------------------------++-- | Offer to add a missing Language Pragma to the top of a file.+-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.+suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]+suggestAddPragma mDynflags Diagnostic {_message, _source}+    | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message+  where+    genPragma target =+      [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]+    disabled+      | Just dynFlags <- mDynflags =+        -- GHC does not export 'OnOff', so we have to view it as string+        mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags)+      | otherwise =+        -- When the module failed to parse, we don't have access to its+        -- dynFlags. In that case, simply don't disable any pragmas.+        []+suggestAddPragma _ _ = []++-- | Find all Pragmas are an infix of the search term.+findPragma :: T.Text -> [T.Text]+findPragma str = concatMap check possiblePragmas+  where+    check p = [p | T.isInfixOf p str]++    -- We exclude the Strict extension as it causes many false positives, see+    -- the discussion at https://github.com/haskell/ghcide/pull/638+    --+    -- We don't include the No- variants, as GHC never suggests disabling an+    -- extension in an error message.+    possiblePragmas :: [T.Text]+    possiblePragmas =+       [ name+       | FlagSpec{flagSpecName = T.pack -> name} <- xFlags+       , "Strict" /= name+       ]++-- | All language pragmas, including the No- variants+allPragmas :: [T.Text]+allPragmas =+  concat+    [ [name, "No" <> name]+    | FlagSpec{flagSpecName = T.pack -> name} <- xFlags+    ]+  <>+  -- These pragmas are not part of xFlags as they are not reversable+  -- by prepending "No".+  [ -- Safe Haskell+    "Unsafe"+  , "Trustworthy"+  , "Safe"++    -- Language Version Extensions+  , "Haskell98"+  , "Haskell2010"+  , "GHC2021"+  ]++-- ---------------------------------------------------------------------+flags :: [T.Text]+flags = map T.pack $ flagsForCompletion False++completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion+completion _ide _ complParams = do+    let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument+        position@(Position ln col) = complParams ^. L.position+    contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri+    fmap LSP.InL $ case (contents, uriToFilePath' uri) of+        (Just cnts, Just _path) ->+            pure $ result $ getCompletionPrefix position cnts+            where+                result pfix+                    | "{-# language" `T.isPrefixOf` line+                    = map mkLanguagePragmaCompl $+                        Fuzzy.simpleFilter word allPragmas+                    | "{-# options_ghc" `T.isPrefixOf` line+                    = let optionPrefix = getGhcOptionPrefix pfix+                          prefixLength = fromIntegral $ T.length optionPrefix+                          prefixRange = LSP.Range (Position ln (col - prefixLength)) position+                      in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter optionPrefix flags+                    | "{-#" `T.isPrefixOf` line+                    = [ mkPragmaCompl (a <> suffix) b c+                      | (a, b, c, w) <- validPragmas, w == NewLine+                      ]+                    | -- Do not suggest any pragmas under any of these conditions:+                      -- 1. Current line is an import+                      -- 2. There is a module name right before the current word.+                      --    Something like `Text.la` shouldn't suggest adding the+                      --    'LANGUAGE' pragma.+                      -- 3. The user has not typed anything yet.+                      "import" `T.isPrefixOf` line || not (T.null module_) || T.null word+                    = []+                    | otherwise+                    = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail+                      | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas+                      , case appearWhere of+                            -- Only suggest a pragma that needs its own line if the whole line+                            -- fuzzily matches the pragma+                            NewLine   -> Fuzzy.test line matcher+                            -- Only suggest a pragma that appears in the middle of a line when+                            -- the current word is not the only thing in the line and the+                            -- current word fuzzily matches the pragma+                            CanInline -> line /= word && Fuzzy.test word matcher+                      ]+                    where+                        line = T.toLower $ fullLine pfix+                        module_ = prefixScope pfix+                        word = prefixText pfix+                        -- Not completely correct, may fail if more than one "{-#" exists.+                        -- We can ignore it since it rarely happens.+                        prefix+                            | "{-# "  `T.isInfixOf` line = ""+                            | "{-#"   `T.isInfixOf` line = " "+                            | otherwise                 = "{-# "+                        suffix+                            | " #-}" `T.isSuffixOf` line = ""+                            | "#-}"  `T.isSuffixOf` line = " "+                            | "-}"   `T.isSuffixOf` line = " #"+                            | "}"    `T.isSuffixOf` line = " #-"+                            | otherwise                 = " #-}"+        _ -> return []++-----------------------------------------------------------------------++-- | Pragma where exist+data AppearWhere =+  NewLine+  -- ^Must be on a new line+  | CanInline+  -- ^Can appear in the line+  deriving (Show, Eq)++validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)]+validPragmas =+  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE"         , "{-# LANGUAGE #-}"         ,   NewLine)+  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC"      , "{-# OPTIONS_GHC #-}"      ,   NewLine)+  , ("INLINE ${1:function}"           , "INLINE"           , "{-# INLINE #-}"           ,   NewLine)+  , ("NOINLINE ${1:function}"         , "NOINLINE"         , "{-# NOINLINE #-}"         ,   NewLine)+  , ("INLINABLE ${1:function}"        , "INLINABLE"        , "{-# INLINABLE #-}"        ,   NewLine)+  , ("WARNING ${1:message}"           , "WARNING"          , "{-# WARNING #-}"          , CanInline)+  , ("DEPRECATED ${1:message}"        , "DEPRECATED"       , "{-# DEPRECATED  #-}"      , CanInline)+  , ("ANN ${1:annotation}"            , "ANN"              , "{-# ANN #-}"              ,   NewLine)+  , ("RULES"                          , "RULES"            , "{-# RULES #-}"            ,   NewLine)+  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE"       , "{-# SPECIALIZE #-}"       ,   NewLine)+  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}",   NewLine)+  , ("SPECIALISE ${1:function}"       , "SPECIALISE"       , "{-# SPECIALISE #-}"       ,   NewLine)+  , ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}",   NewLine)+  , ("MINIMAL ${1:functions}"         , "MINIMAL"          , "{-# MINIMAL #-}"          , CanInline)+  , ("UNPACK"                         , "UNPACK"           , "{-# UNPACK #-}"           , CanInline)+  , ("NOUNPACK"                       , "NOUNPACK"         , "{-# NOUNPACK #-}"         , CanInline)+  , ("COMPLETE ${1:function}"         , "COMPLETE"         , "{-# COMPLETE #-}"         ,   NewLine)+  , ("OVERLAPPING"                    , "OVERLAPPING"      , "{-# OVERLAPPING #-}"      , CanInline)+  , ("OVERLAPPABLE"                   , "OVERLAPPABLE"     , "{-# OVERLAPPABLE #-}"     , CanInline)+  , ("OVERLAPS"                       , "OVERLAPS"         , "{-# OVERLAPS #-}"         , CanInline)+  , ("INCOHERENT"                     , "INCOHERENT"       , "{-# INCOHERENT #-}"       , CanInline)+  ]++mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem+mkPragmaCompl insertText label detail =+  LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing (Just detail)+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet)+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing++mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem+mkLanguagePragmaCompl label =+  LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing++mkGhcOptionCompl :: Range -> T.Text -> LSP.CompletionItem+mkGhcOptionCompl editRange completedFlag =+  LSP.CompletionItem completedFlag Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing (Just insertCompleteFlag) Nothing Nothing Nothing Nothing Nothing+  where+    insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag++-- The prefix extraction logic of getCompletionPrefix+-- doesn't consider '-' part of prefix which breaks completion+-- of flags like "-ddump-xyz". For OPTIONS_GHC completion we need the whole thing+-- to be considered completion prefix, but `prefixText posPrefixInfo` would return"xyz" in this case+getGhcOptionPrefix :: PosPrefixInfo -> T.Text+getGhcOptionPrefix PosPrefixInfo {cursorPos = Position _ col, fullLine}=+  T.takeWhileEnd isGhcOptionChar beforePos+  where+    beforePos = T.take (fromIntegral col) fullLine++    -- Is this character contained in some GHC flag? Based on:+    -- >>> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False+    -- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz"+    isGhcOptionChar :: Char -> Bool+    isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String)
+ plugins/hls-pragmas-plugin/test/Main.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import           Control.Lens               ((<&>), (^.))+import           Data.Aeson+import           Data.Foldable+import qualified Data.Text                  as T+import           Ide.Plugin.Pragmas+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++pragmasSuggestPlugin :: PluginTestDescriptor ()+pragmasSuggestPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas"++pragmasCompletionPlugin :: PluginTestDescriptor ()+pragmasCompletionPlugin = mkPluginTestDescriptor' completionDescriptor "pragmas"++pragmasDisableWarningPlugin :: PluginTestDescriptor ()+pragmasDisableWarningPlugin = mkPluginTestDescriptor' suggestDisableWarningDescriptor "pragmas"++tests :: TestTree+tests =+  testGroup "pragmas"+  [ codeActionTests+  , codeActionTests'+  , completionTests+  , completionSnippetTests+  , dontSuggestCompletionTests+  ]++codeActionTests :: TestTree+codeActionTests =+  testGroup "code actions"+  [ codeActionTestWithPragmasSuggest "Block comment then line comment doesn't split line" "BlockCommentThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then single-line block comment doesn't split line" "BlockCommentThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then multi-line block comment doesn't split line" "BlockCommentThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then line haddock splits line" "BlockCommentThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock splits line" "BlockCommentThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then multi-line block haddock splits line" "BlockCommentThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then line comment doesn't split line" "PragmaThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then single-line block comment doesn't split line" "PragmaThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then multi-line block comment splits line" "PragmaThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then line haddock splits line" "PragmaThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock splits line" "PragmaThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then multi-line block haddock splits line" "PragmaThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock single-line block comment splits line" "PragmaThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock single-line block comment splits line" "BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Pragma then line haddock then newline line comment splits line" "PragmaThenLineHaddockNewlineLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "does not add pragma after OPTIONS_GHC pragma located after a declaration" "OptionsGhcAfterDecl" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" [("Add \"BangPatterns\"", "Contains BangPatterns code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" [("Add \"BangPatterns\"", "Contains BangPatterns code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "adds above module keyword on first line" "ModuleOnFirstLine" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after GHC_OPTIONS" "AfterGhcOptions" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" [("Add \"TupleSections\"", "Contains TupleSections code action")]+  , codeActionTestWithPragmasSuggest "adds TypeApplications pragma" "TypeApplications" [("Add \"TypeApplications\"", "Contains TypeApplications code action")]+  , codeActionTestWithPragmasSuggest "after shebang" "AfterShebang" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "append to existing pragmas" "AppendToExisting" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "before doc comments" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]+  , codeActionTestWithPragmasSuggest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")]+  , codeActionTestWithDisableWarning "before doc comments" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")]+  , codeActionTestWithDisableWarning "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")]+  ]++codeActionTestWithPragmasSuggest :: String -> FilePath -> [(T.Text, String)] -> TestTree+codeActionTestWithPragmasSuggest = codeActionTestWith pragmasSuggestPlugin++codeActionTestWithDisableWarning :: String -> FilePath -> [(T.Text, String)] -> TestTree+codeActionTestWithDisableWarning = codeActionTestWith pragmasDisableWarningPlugin++codeActionTestWith :: PluginTestDescriptor () -> String -> FilePath -> [(T.Text, String)] -> TestTree+codeActionTestWith descriptor testComment fp actions =+  goldenWithPragmas descriptor testComment fp $ \doc -> do+    _ <- waitForDiagnosticsFrom doc+    cas <- map fromAction <$> getAllCodeActions doc+    mapM_ (\(action, contains) -> go action contains cas) actions+    action <- case cas of+      (a:_) -> pure a+      []    -> liftIO $ assertFailure "Expected non-empty list of code actions"+    executeCodeAction action+    where+      go action contains cas = liftIO $ action `elem` map (^. L.title) cas @? contains++codeActionTests' :: TestTree+codeActionTests' =+  testGroup "additional code actions"+  [ goldenWithPragmas pragmasSuggestPlugin "no duplication" "NamedFieldPuns" $ \doc -> do+      _ <- waitForDiagnosticsFrom doc+      cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9))+      ca <- liftIO $ case cas of+        [ca] -> pure ca+        _ -> assertFailure $ "Expected one code action, but got: " <> show cas+      liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action"+      executeCodeAction ca+  , goldenWithPragmas pragmasSuggestPlugin "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do+      _ <- waitForDiagnosticsFrom doc+      cas <- map fromAction <$> getAllCodeActions doc+      liftIO $ "Disable \"deferred-type-errors\" warnings" `notElem` map (^. L.title) cas @? "Doesn't contain deferred-type-errors code action"+      liftIO $ length cas == 0 @? "Expected no code actions, but got: " <> show cas+  ]++completionTests :: TestTree+completionTests =+  testGroup "completions"+  [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 34, 0, 4)+  , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 31, 0, 4)+  , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") (0, 4, 0, 32, 0, 4)+  , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") (0, 4, 0, 33, 0, 4)+  , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") (0, 4, 0, 34, 0, 4)+  , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red  #-}\n" "-Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24)+  , completionTest "completes ghc options pragma values with multiple dashes" "Completion.hs" "{-# OPTIONS_GHC -fmax-worker-ar #-}\n" "-fmax-worker-args" Nothing Nothing Nothing (0, 0, 0, 0, 0, 31)+  , completionTest "completes multiple ghc options within single pragma" "Completion.hs" "{-# OPTIONS_GHC -ddump-simpl -ddump-spl #-}\n" "-ddump-splices" Nothing Nothing Nothing (0, 0, 0, 0, 0, 39)+  , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24)+  , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24)+  , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16)+  , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing (0, 13, 0, 31, 0, 23)+  , completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16)+  ]++completionSnippetTests :: TestTree+completionSnippetTests =+  testGroup "expand snippet to pragma" $+    validPragmas <&>+      (\(insertText, label, detail, appearWhere) ->+        let inputPrefix =+              case appearWhere of+                NewLine   -> ""+                CanInline -> "something "+            input = inputPrefix <> (T.toLower $ T.init label)+        in completionTest (T.unpack label)+            "Completion.hs" input label (Just InsertTextFormat_Snippet)+            (Just $ "{-# " <> insertText <> " #-}") (Just detail)+            (0, 0, 0, 34, 0, fromIntegral $ T.length input))++dontSuggestCompletionTests :: TestTree+dontSuggestCompletionTests =+  testGroup "do not suggest pragmas" $+  let replaceFuncBody newBody = Just $ mkEdit (8,6) (8,8) newBody+      writeInEmptyLine txt = Just $ mkEdit (3,0) (3,0) txt+      generalTests = [ provideNoCompletionsTest "in imports" "Completion.hs" (Just $ mkEdit (3,0) (3,0) "import WA") (Position 3 8)+                     , provideNoCompletionsTest "when no word has been typed" "Completion.hs" Nothing (Position 3 0)+                     , provideNoCompletionsTest "when expecting auto complete on modules" "Completion.hs" (Just $ mkEdit (8,6) (8,8) "Data.Maybe.WA") (Position 8 19)+                     ]+      individualPragmaTests = validPragmas <&> \(_insertText,label,_detail,appearWhere) ->+          let completionPrompt = T.toLower $ T.init label+              promptLen = fromIntegral (T.length completionPrompt)+          in case appearWhere of+              CanInline ->+                  provideNoUndesiredCompletionsTest ("at new line: " <> T.unpack label) "Completion.hs" (Just label) (writeInEmptyLine completionPrompt) (Position 3 0)+              NewLine ->+                  provideNoUndesiredCompletionsTest ("inline: " <> T.unpack label) "Completion.hs" (Just label) (replaceFuncBody completionPrompt) (Position 8 (6 + promptLen))+    in generalTests ++ individualPragmaTests++mkEdit :: (UInt,UInt) -> (UInt,UInt) -> T.Text -> TextEdit+mkEdit (startLine, startCol) (endLine, endCol) newText =+    TextEdit (Range (Position startLine startCol) (Position endLine endCol)) newText++completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> (UInt, UInt, UInt, UInt, UInt, UInt) -> TestTree+completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail (delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol) =+  testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do+    doc <- openDoc fileName "haskell"+    _ <- waitForDiagnostics+    let te = TextEdit (Range (Position delFromLine delFromCol) (Position delToLine delToCol)) replacementText+    _ <- applyEdit doc te+    compls <- getCompletions doc (Position completeAtLine completeAtCol)+    item <- getCompletionByLabel expectedLabel compls+    liftIO $ do+      item ^. L.label @?= expectedLabel+      item ^. L.kind @?= Just CompletionItemKind_Keyword+      item ^. L.insertTextFormat @?= expectedFormat+      item ^. L.insertText @?= expectedInsertText+      item ^. L.detail @?= detail++provideNoCompletionsTest :: String -> FilePath -> Maybe TextEdit -> Position -> TestTree+provideNoCompletionsTest testComment fileName mTextEdit pos =+  provideNoUndesiredCompletionsTest testComment fileName Nothing mTextEdit pos++provideNoUndesiredCompletionsTest :: String -> FilePath -> Maybe T.Text -> Maybe TextEdit -> Position -> TestTree+provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit pos =+  testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do+    setConfigSection "haskell" disableGhcideCompletions+    doc <- openDoc fileName "haskell"+    _ <- waitForDiagnostics+    mapM_ (applyEdit doc) mTextEdit+    compls <- getCompletions doc pos+    liftIO $ case mUndesiredLabel of+        Nothing -> compls @?= []+        Just undesiredLabel -> do+            case find (\c -> c ^. L.label == undesiredLabel) compls of+                Just c -> assertFailure $+                    "Did not expect a completion with label=" <> T.unpack undesiredLabel+                    <> ", got completion: "<> show c+                Nothing -> pure ()++disableGhcideCompletions :: Value+disableGhcideCompletions = object [ "plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]]++goldenWithPragmas :: PluginTestDescriptor () -> TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithPragmas descriptor title path = goldenWithHaskellDoc def descriptor title testDataDir path "expected" "hs"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-pragmas-plugin" </> "test" </> "testdata"
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.expected.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# LANGUAGE BangPatterns #-}++data Metaprogram = Metaprogram+  { mp_name             :: !Text+  , mp_known_by_auto    :: !Bool+  , mp_show_code_action :: !Bool+  , mp_program          :: !(TacticsM ())+  }+  deriving stock Generic+{-# ANN Metaprogram "hello" #-}++instance NFData Metaprogram where+  rnf (!(Metaprogram !_ !_ !_ !_)) = ()
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}++data Metaprogram = Metaprogram+  { mp_name             :: !Text+  , mp_known_by_auto    :: !Bool+  , mp_show_code_action :: !Bool+  , mp_program          :: !(TacticsM ())+  }+  deriving stock Generic+{-# ANN Metaprogram "hello" #-}++instance NFData Metaprogram where+  rnf (!(Metaprogram !_ !_ !_ !_)) = ()
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.expected.hs view
@@ -0,0 +1,21 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE  OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++test :: Int -> Integer+test x = x * 2++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.hs view
@@ -0,0 +1,20 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE  OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++test :: Int -> Integer+test x = x * 2++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module NeedsLanguagePragma where++tupleSection = (1,) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}++module NeedsLanguagePragma where++tupleSection = (1,) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.expected.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.expected.hs view
@@ -0,0 +1,12 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE  OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++test :: Int -> Integer+test x = x * 2
+ plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.hs view
@@ -0,0 +1,11 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE  OverloadedStrings #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++test :: Int -> Integer+test x = x * 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.expected.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TupleSections #-}+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall #-}+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TupleSections #-}+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.hs view
@@ -0,0 +1,10 @@+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE BangPatterns #-}+data Metaprogram = Metaprogram+  { mp_name             :: !Text+  , mp_known_by_auto    :: !Bool+  , mp_show_code_action :: !Bool+  , mp_program          :: !(TacticsM ())+  }+  deriving stock Generic+{-# ANN Metaprogram "hello" #-}++instance NFData Metaprogram where+  rnf (!(Metaprogram !_ !_ !_ !_)) = ()
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.hs view
@@ -0,0 +1,11 @@+data Metaprogram = Metaprogram+  { mp_name             :: !Text+  , mp_known_by_auto    :: !Bool+  , mp_show_code_action :: !Bool+  , mp_program          :: !(TacticsM ())+  }+  deriving stock Generic+{-# ANN Metaprogram "hello" #-}++instance NFData Metaprogram where+  rnf (!(Metaprogram !_ !_ !_ !_)) = ()
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.expected.hs view
@@ -0,0 +1,6 @@+{-#   OPTIONS_GHC -Wall #-}+{-#       LANGUAGE  OverloadedStrings #-}+{-#      OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# LANGUAGE TupleSections #-}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.hs view
@@ -0,0 +1,5 @@+{-#   OPTIONS_GHC -Wall #-}+{-#       LANGUAGE  OverloadedStrings #-}+{-#      OPTIONS_GHC -Wno-deferred-type-errors #-}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs view
@@ -0,0 +1,22 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int+addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs view
@@ -0,0 +1,21 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int+addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1++{-# INLINE subOne #-}+subOne :: Int -> Int+subOne x = x - 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebang.expected.hs view
@@ -0,0 +1,13 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE NamedFieldPuns #-}++module AfterShebang where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebang.hs view
@@ -0,0 +1,12 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module AfterShebang where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs view
@@ -0,0 +1,13 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs view
@@ -0,0 +1,12 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs view
@@ -0,0 +1,18 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs view
@@ -0,0 +1,17 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# INLINE addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs view
@@ -0,0 +1,12 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# LANGUAGE TupleSections #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs view
@@ -0,0 +1,11 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs view
@@ -0,0 +1,16 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE  OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs view
@@ -0,0 +1,15 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE  OverloadedStrings #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.expected.hs view
@@ -0,0 +1,12 @@+-- | Doc before pragma+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+{-# LANGUAGE NamedFieldPuns #-}+module AppendToExisting where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.hs view
@@ -0,0 +1,11 @@+-- | Doc before pragma+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+module AppendToExisting where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.expected.hs view
@@ -0,0 +1,15 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# LANGUAGE NamedFieldPuns #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.hs view
@@ -0,0 +1,14 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.expected.hs view
@@ -0,0 +1,18 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.hs view
@@ -0,0 +1,17 @@+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+-- | Doc Comment+{- Block -}++module BeforeDocComment where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.expected.hs view
@@ -0,0 +1,6 @@+{- block comment -} -- line comment+{-# LANGUAGE TupleSections #-}++module BlockCommentThenLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.hs view
@@ -0,0 +1,5 @@+{- block comment -} -- line comment++module BlockCommentThenLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.expected.hs view
@@ -0,0 +1,7 @@+{- block comment -} +{-# LANGUAGE TupleSections #-}+-- | line haddock++module BlockCommentThenLineHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.hs view
@@ -0,0 +1,5 @@+{- block comment -} -- | line haddock++module BlockCommentThenLineHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.expected.hs view
@@ -0,0 +1,10 @@+{- block comment -} {- multi+line+block+comment+-}+{-# LANGUAGE TupleSections #-}++module BlockCommentThenMultiLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.hs view
@@ -0,0 +1,9 @@+{- block comment -} {- multi+line+block+comment+-}++module BlockCommentThenMultiLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.expected.hs view
@@ -0,0 +1,13 @@+{- block comment -} +{-# LANGUAGE TupleSections #-}+{-| multi+line+block+haddock+-}++module BlockCommentThenMultiLineBlockHaddock where+import Data.List (intercalate)+import System.IO (hFlush)++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.hs view
@@ -0,0 +1,11 @@+{- block comment -} {-| multi+line+block+haddock+-}++module BlockCommentThenMultiLineBlockHaddock where+import Data.List (intercalate)+import System.IO (hFlush)++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.expected.hs view
@@ -0,0 +1,6 @@+{- block comment -} {- single line block comment -}+{-# LANGUAGE TupleSections #-}++module BlockCommentThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.hs view
@@ -0,0 +1,5 @@+{- block comment -} {- single line block comment -}++module BlockCommentThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.expected.hs view
@@ -0,0 +1,7 @@+{- block comment -} +{-# LANGUAGE TupleSections #-}+{-| single line block haddock -}++module BlockCommentThenSingleLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.hs view
@@ -0,0 +1,5 @@+{- block comment -} {-| single line block haddock -}++module BlockCommentThenSingleLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs view
@@ -0,0 +1,7 @@+{- block comment -} +{-# LANGUAGE TupleSections #-}+{-| single line block haddock -} {- single line block comment -}++module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.hs view
@@ -0,0 +1,5 @@+{- block comment -} {-| single line block haddock -} {- single line block comment -}++module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/Completion.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+import           Data.Maybe+import qualified Data.List++main :: IO ()+main = putStrLn "hello"++foo :: Either a b -> Either a b+foo = id
+ plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.expected.hs view
@@ -0,0 +1,4 @@+module DeferredTypeErrors where++foo :: Int+foo = ()
+ plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.hs view
@@ -0,0 +1,4 @@+module DeferredTypeErrors where++foo :: Int+foo = ()
+ plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.expected.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+main = putStrLn "hello"
+ plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -Wall #-}+main = putStrLn "hello"
+ plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TupleSections #-}+module Main where++tupleSection = (1,) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs view
@@ -0,0 +1,3 @@+module Main where++tupleSection = (1,) <$> Just 2
+ plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NamedFieldPuns #-}+module NamedFieldPuns where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.hs view
@@ -0,0 +1,9 @@+module NamedFieldPuns where++data Record = Record+  { a :: Int,+    b :: Double,+    c :: String+  }++f Record{a, b} = a
+ plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TypeSynonymInstances #-}+module NeedsPragmas where++import GHC.Generics++main = putStrLn "hello"++type Foo = Int++instance Show Foo where+  show x = undefined++instance Show (Int,String) where+  show  = undefined++data FFF a = FFF Int String a+           deriving (Generic,Functor,Traversable)
+ plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.hs view
@@ -0,0 +1,16 @@+module NeedsPragmas where++import GHC.Generics++main = putStrLn "hello"++type Foo = Int++instance Show Foo where+  show x = undefined++instance Show (Int,String) where+  show  = undefined++data FFF a = FFF Int String a+           deriving (Generic,Functor,Traversable)
+ plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TupleSections #-}+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# OPTIONS_GHC addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.hs view
@@ -0,0 +1,10 @@+data Something = Something {+    foo :: !String,+    bar :: !Int+}++tupleSection = (1, ) <$> Just 2++{-# OPTIONS_GHC addOne #-}+addOne :: Int -> Int +addOne x = x + 1
+ plugins/hls-pragmas-plugin/test/testdata/PragmaFollowedBySingleLineBlockHaddock.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} {-| haddock -}++module PragmaFollowedByBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeApplications #-} -- line comment+{-# LANGUAGE TupleSections #-}++module PragmaThenLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} -- line comment++module PragmaThenLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+-- | line haddock++module PragmaThenLineHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} -- | line haddock++module PragmaThenLineHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+-- | line haddock+-- line comment++module PragmaThenLineHaddockNewlineLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeApplications #-} -- | line haddock+-- line comment++module PragmaThenLineHaddockNewlineLineComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+{- multi+line+block+comment+-}++module PragmaThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeApplications #-} {- multi+line+block+comment+-}++module PragmaThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+{-| multi+line+block+haddock+-}++module PragmaThenMultiLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeApplications #-} {-| multi+line+block+haddock+-}++module PragmaThenMultiLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeApplications #-} {- single line block comment -}+{-# LANGUAGE TupleSections #-}++module PragmaThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} {- single line block comment -}++module PragmaThenSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+{-| single line block haddock -}++module PragmaThenSingleLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} {-| single line block haddock -}++module PragmaThenSingleLineBlockHaddock where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-}+{-| single line block haddock -} {- single line block comment -}++module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeApplications #-} {-| single line block haddock -} {- single line block comment -}++module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where++a = (1,)
+ plugins/hls-pragmas-plugin/test/testdata/TypeApplications.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module TypeApplications where++foo :: forall a. a -> a+foo = id @a
+ plugins/hls-pragmas-plugin/test/testdata/TypeApplications.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+module TypeApplications where++foo :: forall a. a -> a+foo = id @a
+ plugins/hls-pragmas-plugin/test/testdata/UnusedImports.expected.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+++module M where++import Data.Functor
+ plugins/hls-pragmas-plugin/test/testdata/UnusedImports.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}+++module M where++import Data.Functor
+ plugins/hls-pragmas-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,7 @@+cradle:+  direct:+    arguments:+      - "-XHaskell2010"+      - "NeedsPragmas"+      - "TypeApplications"+      - "NamedFieldPuns"
+ plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}++module Ide.Plugin.QualifyImportedNames (descriptor) where++import           Control.Lens                     ((^.))+import           Control.Monad                    (foldM)+import           Control.Monad.Trans.State.Strict (State)+import qualified Control.Monad.Trans.State.Strict as State+import           Data.DList                       (DList)+import qualified Data.DList                       as DList+import           Data.Foldable                    (Foldable (foldl'), find)+import           Data.List                        (sortOn)+import qualified Data.List                        as List+import qualified Data.Map.Strict                  as Map+import           Data.Maybe                       (fromMaybe, isJust, mapMaybe)+import           Data.Text                        (Text)+import qualified Data.Text                        as Text+import           Development.IDE                  (spanContainsRange)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.RuleTypes   (GetFileContents (GetFileContents),+                                                   GetHieAst (GetHieAst),+                                                   HieAstResult (HAR, refMap),+                                                   TcModuleResult (TcModuleResult, tmrParsed, tmrTypechecked),+                                                   TypeCheck (TypeCheck))+import           Development.IDE.Core.Shake       (IdeState)+import           Development.IDE.GHC.Compat       (ContextInfo (Use),+                                                   GenLocated (..), GhcPs,+                                                   GlobalRdrElt, GlobalRdrEnv,+                                                   HsModule (hsmodImports),+                                                   Identifier,+                                                   IdentifierDetails (IdentifierDetails, identInfo),+                                                   ImpDeclSpec (ImpDeclSpec, is_as, is_dloc, is_qual),+                                                   ImportSpec (ImpSpec),+                                                   LImportDecl, ModuleName,+                                                   Name, NameEnv, ParsedModule,+                                                   RefMap, Span, SrcSpan,+                                                   TcGblEnv (tcg_rdr_env),+                                                   emptyUFM, globalRdrEnvElts,+                                                   gre_imp, gre_name, locA,+                                                   lookupNameEnv,+                                                   moduleNameString,+                                                   nameOccName, occNameString,+                                                   pattern GRE,+                                                   pattern ParsedModule,+                                                   plusUFM_C, pm_parsed_source,+                                                   srcSpanEndCol,+                                                   srcSpanEndLine,+                                                   srcSpanStartCol,+                                                   srcSpanStartLine, unitUFM)+import           Development.IDE.Types.Location   (Position (Position),+                                                   Range (Range), Uri)+import           Ide.Plugin.Error                 (PluginError (PluginRuleFailed),+                                                   getNormalizedFilePathE,+                                                   handleMaybe)+import           Ide.Types                        (PluginDescriptor (pluginHandlers),+                                                   PluginId,+                                                   PluginMethodHandler,+                                                   defaultPluginDescriptor,+                                                   mkPluginHandler)+import qualified Language.LSP.Protocol.Lens       as L+import           Language.LSP.Protocol.Message    (Method (Method_TextDocumentCodeAction),+                                                   SMethod (SMethod_TextDocumentCodeAction))+import           Language.LSP.Protocol.Types      (CodeAction (CodeAction, _command, _data_, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title),+                                                   CodeActionKind (CodeActionKind_QuickFix),+                                                   CodeActionParams (CodeActionParams),+                                                   TextEdit (TextEdit),+                                                   WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),+                                                   type (|?) (InL, InR))++thenCmp :: Ordering -> Ordering -> Ordering+{-# INLINE thenCmp #-}+thenCmp EQ       ordering = ordering+thenCmp ordering _        = ordering++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor pluginId = (defaultPluginDescriptor pluginId "Provides a code action to qualify imported names") {+  pluginHandlers = mconcat+    [ mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider+    ]+}++findLImportDeclAt :: Range -> ParsedModule -> Maybe (LImportDecl GhcPs)+findLImportDeclAt range parsedModule+  | ParsedModule {..} <- parsedModule+  , L _ hsModule <- pm_parsed_source+  , locatedImportDecls <- hsmodImports hsModule =+      find (\ (L (locA -> srcSpan) _) -> fromMaybe False $ srcSpan `spanContainsRange` range) locatedImportDecls++makeCodeActions :: Uri -> [TextEdit] -> [a |? CodeAction]+makeCodeActions uri textEdits = [InR CodeAction {..} | not (null textEdits)]+  where _title = "Qualify imported names"+        _kind = Just CodeActionKind_QuickFix+        _command = Nothing+        _edit = Just WorkspaceEdit {..}+        _changes = Just $ Map.singleton uri textEdits+        _documentChanges = Nothing+        _diagnostics = Nothing+        _isPreferred = Nothing+        _disabled = Nothing+        _data_ = Nothing+        _changeAnnotations = Nothing++data ImportedBy = ImportedBy {+  importedByAlias   :: !ModuleName,+  importedBySrcSpan :: !SrcSpan+}++isRangeWithinImportedBy :: Range -> ImportedBy -> Bool+isRangeWithinImportedBy range ImportedBy{importedBySrcSpan} = fromMaybe False $ spanContainsRange importedBySrcSpan range++globalRdrEnvToNameToImportedByMap :: GlobalRdrEnv -> NameEnv [ImportedBy]+globalRdrEnvToNameToImportedByMap =+  fmap DList.toList . foldl' (plusUFM_C (<>)) emptyUFM . map globalRdrEltToNameToImportedByMap . globalRdrEnvElts+  where+    globalRdrEltToNameToImportedByMap :: GlobalRdrElt -> NameEnv (DList ImportedBy)+    globalRdrEltToNameToImportedByMap GRE {..} =+      unitUFM gre_name $ DList.fromList $ mapMaybe importSpecToImportedBy gre_imp++    importSpecToImportedBy :: ImportSpec -> Maybe ImportedBy+    importSpecToImportedBy (ImpSpec ImpDeclSpec {..} _)+      | is_qual = Nothing+      | otherwise = Just (ImportedBy is_as is_dloc)++data IdentifierSpan = IdentifierSpan {+  identifierSpanLine     :: !Int,+  identifierSpanStartCol :: !Int,+  identifierSpanEndCol   :: !Int+} deriving (Show, Eq)++instance Ord IdentifierSpan where+  compare (IdentifierSpan line1 startCol1 endCol1) (IdentifierSpan line2 startCol2 endCol2) =+    (line1 `compare` line2) `thenCmp` (startCol1 `compare` startCol2) `thenCmp` (endCol1 `compare` endCol2)++realSrcSpanToIdentifierSpan :: Span -> Maybe IdentifierSpan+realSrcSpanToIdentifierSpan realSrcSpan+  | let startLine = srcSpanStartLine realSrcSpan - 1+  , let endLine = srcSpanEndLine realSrcSpan - 1+  , startLine == endLine+  , let startCol = srcSpanStartCol realSrcSpan - 1+  , let endCol = srcSpanEndCol realSrcSpan - 1 =+      Just $ IdentifierSpan startLine startCol endCol+  | otherwise = Nothing++identifierSpanToRange :: IdentifierSpan -> Range+identifierSpanToRange (IdentifierSpan line startCol endCol) =+  Range (Position (fromIntegral line) (fromIntegral startCol)) (Position (fromIntegral line) (fromIntegral endCol))++data UsedIdentifier = UsedIdentifier {+  usedIdentifierName :: !Name,+  usedIdentifierSpan :: !IdentifierSpan+}++refMapToUsedIdentifiers :: RefMap a -> [UsedIdentifier]+refMapToUsedIdentifiers = DList.toList . Map.foldlWithKey' folder DList.empty+  where+    folder acc identifier spanIdentifierDetailsPairs =+      DList.fromList (mapMaybe (uncurry (getUsedIdentifier identifier)) spanIdentifierDetailsPairs) <> acc++    getUsedIdentifier :: Identifier -> Span -> IdentifierDetails a -> Maybe UsedIdentifier+    getUsedIdentifier identifier span IdentifierDetails {..}+      | Just identifierSpan <- realSrcSpanToIdentifierSpan span+      , Right name <- identifier+      , Use `elem` identInfo = Just $ UsedIdentifier name identifierSpan+      | otherwise = Nothing++updateColOffset :: Int -> Int -> Int -> Int+updateColOffset row lineOffset colOffset+  | row == lineOffset = colOffset+  | otherwise = 0++usedIdentifiersToTextEdits :: Range -> NameEnv [ImportedBy] -> Text -> [UsedIdentifier] -> [TextEdit]+usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers+  | let sortedUsedIdentifiers = sortOn usedIdentifierSpan usedIdentifiers =+      State.evalState (makeStateComputation sortedUsedIdentifiers) (Text.lines sourceText, 0, 0)+  where+    folder :: [TextEdit] -> UsedIdentifier -> State ([Text], Int, Int) [TextEdit]+    folder prevTextEdits UsedIdentifier{usedIdentifierName, usedIdentifierSpan}+      | Just importedBys <- lookupNameEnv nameToImportedByMap usedIdentifierName+      , Just ImportedBy{importedByAlias} <- find (isRangeWithinImportedBy range) importedBys+      , let IdentifierSpan row startCol _ = usedIdentifierSpan+      , let identifierRange = identifierSpanToRange usedIdentifierSpan+      , let aliasText = Text.pack $ moduleNameString importedByAlias+      , let identifierText = Text.pack $ occNameString $ nameOccName usedIdentifierName+      , let qualifiedIdentifierText = aliasText <> "." <> identifierText = do+          (sourceTextLines, lineOffset, updateColOffset row lineOffset -> colOffset) <- State.get+          let lines = List.drop (row - lineOffset) sourceTextLines+          let (replacementText, remainingLines) =+                if | line : remainingLines <- lines+                   , let lineStartingAtIdentifier = Text.drop (startCol - colOffset) line+                   , Just (c, _) <- Text.uncons lineStartingAtIdentifier+                   , let isParenthesized = c == '('+                   , let isBackticked = c == '`'+                   , let replacementText =+                           if | isParenthesized -> "(" <> qualifiedIdentifierText <> ")"+                              | isBackticked -> "`" <> qualifiedIdentifierText <> "`"+                              | otherwise -> qualifiedIdentifierText ->+                       (replacementText, lineStartingAtIdentifier : remainingLines)+                   | otherwise -> (qualifiedIdentifierText, lines)+          let textEdit = TextEdit identifierRange replacementText+          State.put (remainingLines, row, startCol)+          pure $ textEdit : prevTextEdits+      | otherwise = pure prevTextEdits++    makeStateComputation :: [UsedIdentifier] -> State ([Text], Int, Int) [TextEdit]+    makeStateComputation usedIdentifiers = foldM folder [] usedIdentifiers++-- The overall idea:+-- 1. GlobalRdrEnv from typechecking phase contains info on what imported a+--    name.+-- 2. refMap from GetHieAst contains location of names and how they are used.+-- 3. For each used name in refMap check whether the name comes from an import+--    at the origin of the code action.+codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId range _) = do+  normalizedFilePath <- getNormalizedFilePathE (documentId ^. L.uri)+  TcModuleResult { tmrParsed, tmrTypechecked } <- runActionE "QualifyImportedNames.TypeCheck" ideState $ useE TypeCheck normalizedFilePath+  if isJust (findLImportDeclAt range tmrParsed)+    then do+          HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst normalizedFilePath)+          (_, sourceTextM) <-  runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath)+          sourceText <- handleMaybe (PluginRuleFailed "GetFileContents") sourceTextM+          let globalRdrEnv = tcg_rdr_env tmrTypechecked+              nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv+              usedIdentifiers = refMapToUsedIdentifiers refMap+              textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers+          pure  $ InL (makeCodeActions (documentId ^. L.uri) textEdits)+    else pure  $ InL []+
+ plugins/hls-qualify-imported-names-plugin/test/Main.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Main (main) where++import           Data.Foldable                   (find)+import           Data.Text                       (Text)+import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames+import           System.FilePath                 ((</>))+import           Test.Hls                        (CodeAction (CodeAction, _title),+                                                  Command, MonadIO (liftIO),+                                                  PluginTestDescriptor,+                                                  Position (Position),+                                                  Range (Range), Session,+                                                  TestName, TestTree,+                                                  TextDocumentIdentifier,+                                                  assertBool, assertFailure,+                                                  def, defaultTestRunner,+                                                  executeCodeAction,+                                                  getCodeActions,+                                                  goldenWithHaskellDoc,+                                                  mkPluginTestDescriptor',+                                                  openDoc, runSessionWithServer,+                                                  testCase, testGroup,+                                                  type (|?) (InR))++import           Prelude++-- 1's based+data Point = Point {+  line   :: !Int,+  column :: !Int+}++makePoint :: Int -> Int -> Point+makePoint line column+  | line >= 1 && column >= 1 = Point line column+  | otherwise = error "Line or column is less than 1."++isEmpty :: Foldable f => f a -> Bool+isEmpty = null++makeCodeActionNotFoundAtString :: Point -> String+makeCodeActionNotFoundAtString Point {..} =+  "CodeAction not found at line: " <> show line <> ", column: " <> show column++makeCodeActionFoundAtString :: Point -> String+makeCodeActionFoundAtString Point {..} =+  "CodeAction found at line: " <> show line <> ", column: " <> show column++main :: IO ()+main = defaultTestRunner $ testGroup "Qualify Imported Names"+  [+    testCase "No CodeAction when not at import" $+      runSessionWithServer def pluginDescriptor testDataDir $ do+        let point = makePoint 1 1+        document <- openDoc "NoImport.hs" "haskell"+        actions <- getCodeActions document $ pointToRange point+        liftIO $ assertBool (makeCodeActionFoundAtString point) (isEmpty actions)+  , testCase "No CodeAction when import is qualified" $+      runSessionWithServer def pluginDescriptor testDataDir $ do+        let point = makePoint 3 1+        document <- openDoc "QualifiedImport.hs" "haskell"+        actions <- getCodeActions document $ pointToRange point+        liftIO $ assertBool (makeCodeActionFoundAtString point) (isEmpty actions)+  , codeActionGoldenTest+      "CodeAction qualifies names with alias if imported module is aliased"+      "AliasedImport"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies names with module name if imported module is not aliased"+      "UnaliasedImport"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies only names in import's explicit non-hiding list"+      "ExplicitImport"+      (makePoint 4 1)+  , codeActionGoldenTest+      "CodeAction qualifies only names outside of import's explicit hiding list"+      "ExplicitHidingImport"+      (makePoint 4 1)+  , codeActionGoldenTest+      "CodeAction can qualify names not defined in modules they are imported from"+      "Reexported"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction can qualify explicitly imported Prelude"+      "ExplicitPrelude"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies only imported names"+      "OnlyImportedNames"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies parenthesized operators properly"+      "Parenthesized"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies backticked operators properly"+      "Backticked"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction qualifies parenthesized and backticked operators on the same line properly"+      "SameLine"+      (makePoint 3 1)+  , codeActionGoldenTest+      "CodeAction doesn't qualify already qualified names"+      "NoDoubleQualify"+      (makePoint 3 1)+  ]++codeActionGoldenTest :: TestName -> FilePath -> Point -> TestTree+codeActionGoldenTest testCaseName goldenFilename point =+  goldenWithQualifyImportedNames testCaseName goldenFilename $ \document -> do+    actions <- getCodeActions document $ pointToRange point+    case find ((== Just "Qualify imported names") . getCodeActionTitle) actions of+      Just (InR codeAction) -> executeCodeAction codeAction+      _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point++testDataDir :: String+testDataDir = "plugins" </> "hls-qualify-imported-names-plugin" </> "test" </> "data"++pluginDescriptor :: PluginTestDescriptor ()+pluginDescriptor = mkPluginTestDescriptor' QualifyImportedNames.descriptor "qualifyImportedNames"++getCodeActionTitle :: (Command |? CodeAction) -> Maybe Text+getCodeActionTitle commandOrCodeAction+  | InR CodeAction {_title} <- commandOrCodeAction = Just _title+  | otherwise = Nothing++goldenWithQualifyImportedNames :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithQualifyImportedNames testName path =+  goldenWithHaskellDoc def pluginDescriptor testName testDataDir path "expected" "hs"++pointToRange :: Point -> Range+pointToRange Point {..}+  | line <- fromIntegral $ subtract 1 line+  , column <- fromIntegral $ subtract 1 column =+      Range (Position line column) (Position line $ column + 1)+
+ plugins/hls-qualify-imported-names-plugin/test/data/A.hs view
@@ -0,0 +1,12 @@+module A (module B, a, b, op) where++import B++a :: Int -> Int+a = id++b :: String -> String+b = id++op :: Int -> Int -> Int+op = (+)
+ plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.expected.hs view
@@ -0,0 +1,6 @@+module AliasedImport where++import A as B++thing = B.a+
+ plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.hs view
@@ -0,0 +1,6 @@+module AliasedImport where++import A as B++thing = a+
+ plugins/hls-qualify-imported-names-plugin/test/data/B.hs view
@@ -0,0 +1,7 @@+module B where++c :: Int+c = 3++d :: String+d = "d"
+ plugins/hls-qualify-imported-names-plugin/test/data/Backticked.expected.hs view
@@ -0,0 +1,10 @@+module Backticked where++import Prelude++f a b = a `Prelude.elem` b++g a b =+  let h = f a b+  in a `Prelude.elem` b+
+ plugins/hls-qualify-imported-names-plugin/test/data/Backticked.hs view
@@ -0,0 +1,10 @@+module Backticked where++import Prelude++f a b = a `elem` b++g a b =+  let h = f a b+  in a `elem` b+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.expected.hs view
@@ -0,0 +1,8 @@+module ExplicitHidingImport where++import A+import A hiding (b)++thing1 = A.a+thing2 = b+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.hs view
@@ -0,0 +1,8 @@+module ExplicitHidingImport where++import A+import A hiding (b)++thing1 = a+thing2 = b+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.expected.hs view
@@ -0,0 +1,8 @@+module ExplicitImport where++import A (a)+import A (b)++thing1 = a+thing2 = A.b+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.hs view
@@ -0,0 +1,8 @@+module ExplicitImport where++import A (a)+import A (b)++thing1 = a+thing2 = b+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.expected.hs view
@@ -0,0 +1,10 @@+module ExplicitPrelude where++import Prelude++f :: Prelude.String -> Prelude.Int -> Prelude.Maybe Prelude.Bool+f a b = Prelude.Just Prelude.False ++class Prelude.Functor f => MyClass f where+  method :: f Prelude.Int+
+ plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.hs view
@@ -0,0 +1,10 @@+module ExplicitPrelude where++import Prelude++f :: String -> Int -> Maybe Bool+f a b = Just False ++class Functor f => MyClass f where+  method :: f Int+
+ plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.expected.hs view
@@ -0,0 +1,7 @@+module NoDoubleQualify where++import A as AAA++thing = AAA.a+thing2 = (AAA.op)+thing3 = 1 `AAA.op` 2
+ plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.hs view
@@ -0,0 +1,7 @@+module NoDoubleQualify where++import A as AAA++thing = AAA.a+thing2 = (AAA.op)+thing3 = 1 `AAA.op` 2
+ plugins/hls-qualify-imported-names-plugin/test/data/NoImport.hs view
@@ -0,0 +1,4 @@+module NoImport where++f = 3+
+ plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.expected.hs view
@@ -0,0 +1,16 @@+module OnlyImportedNames where++import A++thing1 a = a++thing2 b = b++thing3 = f1 A.a A.c++thing4 = f2 A.b A.d++f1 a = a++f2 c b = let { d = "k"; e = A.a } in c d ++ c b+
+ plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.hs view
@@ -0,0 +1,16 @@+module OnlyImportedNames where++import A++thing1 a = a++thing2 b = b++thing3 = f1 a c++thing4 = f2 b d++f1 a = a++f2 c b = let { d = "k"; e = a } in c d ++ c b+
+ plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.expected.hs view
@@ -0,0 +1,6 @@+module Parenthesized where++import Prelude++thing :: [Prelude.Int] -> [Prelude.Int] -> [Prelude.Int]+thing = (Prelude.<>)
+ plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.hs view
@@ -0,0 +1,6 @@+module Parenthesized where++import Prelude++thing :: [Int] -> [Int] -> [Int]+thing = (<>)
+ plugins/hls-qualify-imported-names-plugin/test/data/QualifiedImport.hs view
@@ -0,0 +1,4 @@+module QualifiedImport where++import qualified A+
+ plugins/hls-qualify-imported-names-plugin/test/data/Reexported.expected.hs view
@@ -0,0 +1,6 @@+module Reexported where++import A++thing = A.c+
+ plugins/hls-qualify-imported-names-plugin/test/data/Reexported.hs view
@@ -0,0 +1,6 @@+module Reexported where++import A++thing = c+
+ plugins/hls-qualify-imported-names-plugin/test/data/SameLine.expected.hs view
@@ -0,0 +1,5 @@+module SameLine where++import A++thing = ((A.a) . (A.a) . (A.a)) (1 `A.op` 2 `A.op` 3 `A.op` 4)
+ plugins/hls-qualify-imported-names-plugin/test/data/SameLine.hs view
@@ -0,0 +1,5 @@+module SameLine where++import A++thing = ((a) . (a) . (a)) (1 `op` 2 `op` 3 `op` 4)
+ plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.expected.hs view
@@ -0,0 +1,6 @@+module UnaliasedImport where++import A++thing = A.a+
+ plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.hs view
@@ -0,0 +1,6 @@+module UnaliasedImport where++import A++thing = a+
+ plugins/hls-qualify-imported-names-plugin/test/data/hie.yaml view
@@ -0,0 +1,17 @@+cradle:+  direct:+    arguments:+    - A.hs+    - B.hs+    - QualifiedImport.hs+    - NoImport.hs+    - AliasedImport.hs+    - UnaliasedImport.hs+    - ExplicitImport.hs+    - ExplicitHidingImport.hs+    - Reexported.hs+    - ExplicitPrelude.hs+    - OnlyImportedNames.hs+    - Parenthesized.hs+    - Backticked.hs+
+ plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs view
@@ -0,0 +1,17 @@+-- | This module contains compatibility constructs to write type signatures across+--   multiple ghc-exactprint versions, accepting that anything more ambitious is+--   pretty much impossible with the GHC 9.2 redesign of ghc-exactprint+module Development.IDE.GHC.Compat.ExactPrint+    ( ExactPrint+    , exactPrint+    , makeDeltaAst+    , Retrie.Annotated, pattern Annotated, astA, annsA+    ) where++import           Development.IDE.GHC.Compat.Parser+import           Language.Haskell.GHC.ExactPrint   as Retrie+import qualified Retrie.ExactPrint                 as Retrie+++pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast+pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))
+ plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE CPP #-}+module Development.IDE.GHC.Dump(showAstDataHtml) where+import qualified Data.ByteString                       as B+import           Data.Data                             hiding (Fixity)+import           Development.IDE.GHC.Compat            hiding (LocatedA,+                                                        NameAnn)+import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.Compat.Util+import           Generics.SYB                          (ext1Q, ext2Q, extQ)+import           GHC.Hs                                hiding (AnnLet)+import           GHC.Hs.Dump+import           GHC.Plugins                           hiding (AnnLet)+import           Prelude                               hiding ((<>))++-- | Show a GHC syntax tree in HTML.+showAstDataHtml :: (Data a, ExactPrint a) => a -> SDoc+showAstDataHtml a0 = html $+    header $$+    body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat+        [+            li (pre $ text (exactPrint a0)),+            li (showAstDataHtml' a0),+            li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)+        ])+  where+    tag = tag' []+    tag' attrs t cont =+        angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs])+        <> cont+        <> angleBrackets (char '/' <> text t)+    ul = tag' [("class", text (show @String "nested"))] "ul"+    li = tag "li"+    caret x = tag' [("class", text "caret")] "span" "" <+> x+    nested foo cts+#if !MIN_VERSION_ghc(9,3,0)+      | cts == empty = foo+#endif+      | otherwise = foo $$ (caret $ ul cts)+    body cts = tag "body" $ cts $$ tag "script" (text js)+    header = tag "head" $ tag "style" $ text css+    html = tag "html"+    pre = tag "pre"+    showAstDataHtml' :: Data a => a -> SDoc+    showAstDataHtml' =+      generic+              `ext1Q` list+              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan+              `extQ` annotation+              `extQ` annotationModule+              `extQ` annotationAddEpAnn+              `extQ` annotationGrhsAnn+              `extQ` annotationEpAnnHsCase+              `extQ` annotationEpAnnHsLet+              `extQ` annotationAnnList+              `extQ` annotationEpAnnImportDecl+              `extQ` annotationAnnParen+              `extQ` annotationTrailingAnn+              `extQ` annotationEpaLocation+              `extQ` addEpAnn+              `extQ` lit `extQ` litr `extQ` litt+              `extQ` sourceText+              `extQ` deltaPos+              `extQ` epaAnchor+              `extQ` anchorOp+              `extQ` bytestring+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var+              `extQ` dataCon+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+              `extQ` fixity+              `ext2Q` located+              `extQ` srcSpanAnnA+              `extQ` srcSpanAnnL+              `extQ` srcSpanAnnP+              `extQ` srcSpanAnnC+              `extQ` srcSpanAnnN++      where generic :: Data a => a -> SDoc+            generic t = nested (text $ showConstr (toConstr t))+                     (vcat (gmapQ (li . showAstDataHtml') t))++            string :: String -> SDoc+            string = text . normalize_newlines . show++            fastString :: FastString -> SDoc+            fastString s = braces $+                            text "FastString:"+                        <+> text (normalize_newlines . show $ s)++            bytestring :: B.ByteString -> SDoc+            bytestring = text . normalize_newlines . show++            list []  = brackets empty+            list [x] = "[]" $$ showAstDataHtml' x+            list xs  = nested "[]" (vcat $ map (li . showAstDataHtml') xs)++            -- Eliminate word-size dependence+            lit :: HsLit GhcPs -> SDoc+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            lit l                  = generic l++            litr :: HsLit GhcRn -> SDoc+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litr l                  = generic l++            litt :: HsLit GhcTc -> SDoc+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litt l                  = generic l++            numericLit :: String -> Integer -> SourceText -> SDoc+            numericLit tag x s = braces $ hsep [ text tag+                                               , generic x+                                               , generic s ]++            sourceText :: SourceText -> SDoc+            sourceText NoSourceText     = text "NoSourceText"+#if MIN_VERSION_ghc(9,7,0)+            sourceText (SourceText src) = text "SourceText" <+> ftext src+#else+            sourceText (SourceText src) = text "SourceText" <+> text src+#endif++            epaAnchor :: EpaLocation -> SDoc+#if MIN_VERSION_ghc(9,5,0)+            epaAnchor (EpaSpan r _)  = text "EpaSpan" <+> realSrcSpan r+#else+            epaAnchor (EpaSpan r)  = text "EpaSpan" <+> realSrcSpan r+#endif+            epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs++            anchorOp :: AnchorOperation -> SDoc+            anchorOp UnchangedAnchor  = "UnchangedAnchor"+            anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp++            deltaPos :: DeltaPos -> SDoc+            deltaPos (SameLine c) = text "SameLine" <+> ppr c+            deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c++            name :: Name -> SDoc+            name nm    = braces $ text "Name:" <+> ppr nm++            occName n  =  braces $+                          text "OccName:"+                      <+> text (occNameString n)++            moduleName :: ModuleName -> SDoc+            moduleName m = braces $ text "ModuleName:" <+> ppr m++            srcSpan :: SrcSpan -> SDoc+            srcSpan ss = char ' ' <>+                             hang (ppr ss) 1+                                   -- TODO: show annotations here+                                   (text "")++            realSrcSpan :: RealSrcSpan -> SDoc+            realSrcSpan ss = braces $ char ' ' <>+                             hang (ppr ss) 1+                                   -- TODO: show annotations here+                                   (text "")++            addEpAnn :: AddEpAnn -> SDoc+            addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s++            var  :: Var -> SDoc+            var v      = braces $ text "Var:" <+> ppr v++            dataCon :: DataCon -> SDoc+            dataCon c  = braces $ text "DataCon:" <+> ppr c++            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc+            bagRdrName bg =  braces $+                             text "Bag(LocatedA (HsBind GhcPs)):"+                          $$ (list . bagToList $ bg)++            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc+            bagName bg  =  braces $+                           text "Bag(LocatedA (HsBind Name)):"+                        $$ (list . bagToList $ bg)++            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc+            bagVar bg  =  braces $+                          text "Bag(LocatedA (HsBind Var)):"+                       $$ (list . bagToList $ bg)++            nameSet ns =  braces $+                          text "NameSet:"+                       $$ (list . nameSetElemsStable $ ns)++            fixity :: Fixity -> SDoc+            fixity fx =  braces $+                         text "Fixity:"+                     <+> ppr fx++            located :: (Data a, Data b) => GenLocated a b -> SDoc+            located (L ss a)+              = nested "L" (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a))++            -- -------------------------++            annotation :: EpAnn [AddEpAnn] -> SDoc+            annotation = annotation' (text "EpAnn [AddEpAnn]")++            annotationModule :: EpAnn AnnsModule -> SDoc+            annotationModule = annotation' (text "EpAnn AnnsModule")++            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc+            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")++            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc+            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")++            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc+            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")++#if MIN_VERSION_ghc(9,4,0)+            annotationEpAnnHsLet :: EpAnn NoEpAnns -> SDoc+            annotationEpAnnHsLet = annotation' (text "EpAnn NoEpAnns")+#else+            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc+            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")+#endif++            annotationAnnList :: EpAnn AnnList -> SDoc+            annotationAnnList = annotation' (text "EpAnn AnnList")++            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")++            annotationAnnParen :: EpAnn AnnParen -> SDoc+            annotationAnnParen = annotation' (text "EpAnn AnnParen")++            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc+            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")++            annotationEpaLocation :: EpAnn EpaLocation -> SDoc+            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")++            annotation' :: forall a. Data a => SDoc -> EpAnn a -> SDoc+            annotation' _tag anns = nested (text $ showConstr (toConstr anns))+              (vcat (map li $ gmapQ showAstDataHtml' anns))++            -- -------------------------++            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")++            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")++            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")++            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")++            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")++            locatedAnn'' :: forall a. Data a+              => SDoc -> SrcSpanAnn' a -> SDoc+            locatedAnn'' tag ss =+              case cast ss of+                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                      nested "SrcSpanAnn" (+                                 li(showAstDataHtml' ann)+                              $$ li(srcSpan s))+                Nothing -> text "locatedAnn:unmatched" <+> tag+                           <+> text (showConstr (toConstr ss))+++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs)                 = x:normalize_newlines xs+normalize_newlines []                     = []++css :: String+css = unlines+  [ "body {background-color: black; color: white ;}"+  , "/* Remove default bullets */"+  , "ul, #myUL {"+  , "  list-style-type: none;"+  , "}"+  , "/* Remove margins and padding from the parent ul */"+  , "#myUL {"+  , "  margin: 0;                       "+  , "  padding: 0;                      "+  , "}                                  "+  , "/* Style the caret/arrow */        "+  , ".caret {                           "+  , "  cursor: pointer;                 "+  , "  user-select: none; /* Prevent text selection */"+  , "}                                  "+  , "/* Create the caret/arrow with a unicode, and style it */"+  , ".caret::before {                   "+  , "  content: \"\\25B6 \";                "+  , "  color: white;                    "+  , "  display: inline-block;           "+  , "  margin-right: 6px;               "+  , "}                                  "+  , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */"+  , ".caret-down::before {              "+  , "  transform: rotate(90deg);        "+  , "}                                  "+  , "/* Hide the nested list */         "+  , ".nested {                          "+  , "  display: none;                   "+  , "}                                  "+  , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */"+  , ".active {                          "+  , "  display: block;}"+  ]++js :: String+js = unlines+  [ "var toggler = document.getElementsByClassName(\"caret\");"+  , "var i;"+  , "for (i = 0; i < toggler.length; i++) {"+  , "  toggler[i].addEventListener(\"click\", function() {"+  , "    this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");"+  , "    this.classList.toggle(\"caret-down\");"+  , "  }); }"+  ]
+ plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs view
@@ -0,0 +1,741 @@+{-# LANGUAGE GADTs        #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module hosts various abstractions and utility functions to work with ghc-exactprint.+module Development.IDE.GHC.ExactPrint+    ( Graft(..),+      graftDecls,+      graftDeclsWithM,+      annotate,+      annotateDecl,+      hoistGraft,+      graftWithM,+      graftExprWithM,+      genericGraftWithSmallestM,+      genericGraftWithLargestM,+      graftSmallestDeclsWithM,+      transform,+      transformM,+      ExactPrint(..),+      modifySmallestDeclWithM,+      modifyMgMatchesT,+      modifyMgMatchesT',+      modifySigWithM,+      genAnchor1,+      setPrecedingLines,+      addParens,+      addParensToCtxt,+      modifyAnns,+      removeComma,+      -- * Helper function+      eqSrcSpan,+      eqSrcSpanA,+      epl,+      epAnn,+      removeTrailingComma,+      annotateParsedSource,+      getAnnotatedParsedSourceRule,+      GetAnnotatedParsedSource(..),+      ASTElement (..),+      ExceptStringT (..),+      TransformT,+      Log(..),+    )+where++import           Control.Applicative                     (Alternative)+import           Control.Arrow                           ((***))+import           Control.DeepSeq+import           Control.Monad+import qualified Control.Monad.Fail                      as Fail+import           Control.Monad.IO.Class                  (MonadIO)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Zip+import           Data.Bifunctor+import           Data.Bool                               (bool)+import           Data.Default                            (Default)+import qualified Data.DList                              as DL+import           Data.Either.Extra                       (mapLeft)+import           Data.Functor.Classes+import           Data.Functor.Contravariant+import           Data.Monoid                             (All (All), getAll)+import qualified Data.Text                               as T+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake              hiding (Log)+import qualified Development.IDE.Core.Shake              as Shake+import           Development.IDE.GHC.Compat              hiding (parseImport,+                                                          parsePattern,+                                                          parseType)+import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.Graph                   (RuleResult, Rules)+import           Development.IDE.Graph.Classes+import           Generics.SYB+import           Generics.SYB.GHC+import qualified GHC.Generics                            as GHC+import           Ide.Logger                              (Pretty (pretty),+                                                          Recorder,+                                                          WithPriority,+                                                          cmapWithPrio)+import           Ide.PluginUtils+import           Language.Haskell.GHC.ExactPrint.Parsers+import           Language.LSP.Protocol.Types+import           Retrie.ExactPrint                       hiding (parseDecl,+                                                          parseExpr,+                                                          parsePattern,+                                                          parseType)+#if MIN_VERSION_ghc(9,9,0)+import           GHC.Plugins                             (showSDoc)+import           GHC.Utils.Outputable                    (Outputable (ppr))+#else+import           GHC                                     (EpAnn (..),+                                                          NameAdornment (NameParens),+                                                          NameAnn (..),+                                                          SrcSpanAnn' (SrcSpanAnn),+                                                          SrcSpanAnnA,+                                                          TrailingAnn (AddCommaAnn),+                                                          emptyComments,+                                                          spanAsAnchor)+import           GHC.Parser.Annotation                   (AnnContext (..),+                                                          EpaLocation (EpaDelta),+                                                          deltaPos)+#endif++import           Control.Lens                            (_last, (&))+import           Control.Lens.Operators                  ((%~))+import           Data.List                               (partition)+import           GHC                                     (Anchor (..),+                                                          AnchorOperation,+                                                          DeltaPos (..),+                                                          SrcSpanAnnN,+                                                          realSrcSpan)+import           GHC.Types.SrcLoc                        (generatedSrcSpan)++setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a+setPrecedingLines ast n c = setEntryDP ast (deltaPos n c)+------------------------------------------------------------------------------++data Log = LogShake Shake.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog++instance Show (Annotated ParsedSource) where+  show _ = "<Annotated ParsedSource>"++instance NFData (Annotated ParsedSource) where+  rnf = rwhnf++data GetAnnotatedParsedSource = GetAnnotatedParsedSource+  deriving (Eq, Show, Typeable, GHC.Generic)++instance Hashable GetAnnotatedParsedSource+instance NFData GetAnnotatedParsedSource+type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource++-- | Get the latest version of the annotated parse source with comments.+getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules ()+getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do+  pm <- use GetParsedModuleWithComments nfp+  return ([], fmap annotateParsedSource pm)++annotateParsedSource :: ParsedModule -> Annotated ParsedSource+annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0++------------------------------------------------------------------------------++{- | A transformation for grafting source trees together. Use the semigroup+ instance to combine 'Graft's, and run them via 'transform'.+-}+newtype Graft m a = Graft+    { runGraft :: DynFlags -> a -> TransformT m a+    }++hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a+hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f)++newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a}+    deriving newtype+        ( MonadTrans+        , Monad+        , Functor+        , Applicative+        , Alternative+        , Foldable+        , Contravariant+        , MonadIO+        , Eq1+        , Ord1+        , Show1+        , Read1+        , MonadZip+        , MonadPlus+        , Eq+        , Ord+        , Show+        , Read+        )++instance Monad m => Fail.MonadFail (ExceptStringT m) where+    fail = ExceptStringT . ExceptT . pure . Left++instance Monad m => Semigroup (Graft m a) where+    Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags++instance Monad m => Monoid (Graft m a) where+    mempty = Graft $ const pure++------------------------------------------------------------------------------++-- | Convert a 'Graft' into a 'WorkspaceEdit'.+transform ::+    DynFlags ->+    ClientCapabilities ->+    VersionedTextDocumentIdentifier ->+    Graft (Either String) ParsedSource ->+    Annotated ParsedSource ->+    Either String WorkspaceEdit+transform dflags ccs verTxtDocId f a = do+    let src = printA a+    a' <- transformA a $ runGraft f dflags+    let res = printA a'+    pure $ diffText ccs (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions++------------------------------------------------------------------------------++-- | Convert a 'Graft' into a 'WorkspaceEdit'.+transformM ::+    Monad m =>+    DynFlags ->+    ClientCapabilities ->+    VersionedTextDocumentIdentifier ->+    Graft (ExceptStringT m) ParsedSource ->+    Annotated ParsedSource ->+    m (Either String WorkspaceEdit)+transformM dflags ccs verTextDocId f a = runExceptT $+    runExceptString $ do+        let src = printA a+        a' <- transformA a $ runGraft f dflags+        let res = printA a'+        pure $ diffText ccs (verTextDocId, T.pack src) (T.pack res) IncludeDeletions+++-- | Returns whether or not this node requires its immediate children to have+-- be parenthesized and have a leading space.+--+-- A more natural type for this function would be to return @(Bool, Bool)@, but+-- we use 'All' instead for its monoid instance.+needsParensSpace ::+    HsExpr GhcPs ->+    -- | (Needs parens, needs space)+    (All, All)+needsParensSpace HsLam{}         = (All False, All False)+needsParensSpace HsLamCase{}     = (All False, All True)+needsParensSpace HsApp{}         = mempty+needsParensSpace HsAppType{}     = mempty+needsParensSpace OpApp{}         = mempty+needsParensSpace HsPar{}         = (All False, All False)+needsParensSpace SectionL{}      = (All False, All False)+needsParensSpace SectionR{}      = (All False, All False)+needsParensSpace ExplicitTuple{} = (All False, All False)+needsParensSpace ExplicitSum{}   = (All False, All False)+needsParensSpace HsCase{}        = (All False, All True)+needsParensSpace HsIf{}          = (All False, All False)+needsParensSpace HsMultiIf{}     = (All False, All False)+needsParensSpace HsLet{}         = (All False, All True)+needsParensSpace HsDo{}          = (All False, All False)+needsParensSpace ExplicitList{}  = (All False, All False)+needsParensSpace RecordCon{}     = (All False, All True)+needsParensSpace RecordUpd{}     = mempty+needsParensSpace _               = mempty+++------------------------------------------------------------------------------++{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the+ given @Located ast@. The node at that position must already be a @Located+ ast@, or this is a no-op.+-}+graft' ::+    forall ast a l.+    (Data a, ASTElement l ast) =>+    -- | Do we need to insert a space before this grafting? In do blocks, the+    -- answer is no, or we will break layout. But in function applications,+    -- the answer is yes, or the function call won't get its argument. Yikes!+    --+    -- More often the answer is yes, so when in doubt, use that.+    Bool ->+    SrcSpan ->+    LocatedAn l ast ->+    Graft (Either String) a+graft' needs_space dst val = Graft $ \dflags a -> do+    val' <- annotate dflags needs_space val+    pure $+        everywhere'+            ( mkT $+                \case+                    (L src _ :: LocatedAn l ast)+                        | locA src `eqSrcSpan` dst -> val'+                    l                         -> l+            )+            a+++-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts+-- parentheses if they're necessary.+graftExpr ::+    forall a.+    (Data a) =>+    SrcSpan ->+    LHsExpr GhcPs ->+    Graft (Either String) a+graftExpr dst val = Graft $ \dflags a -> do+    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a++    runGraft+      (graft' needs_space dst $ mk_parens val)+      dflags+      a++getNeedsSpaceAndParenthesize ::+    (ASTElement l ast, Data a) =>+    SrcSpan ->+    a ->+    (Bool, LocatedAn l ast -> LocatedAn l ast)+getNeedsSpaceAndParenthesize dst a =+  -- Traverse the tree, looking for our replacement node. But keep track of+  -- the context (parent HsExpr constructor) we're in while we do it. This+  -- lets us determine whether or not we need parentheses.+  let (needs_parens, needs_space) =+          everythingWithContext (Nothing, Nothing) (<>)+            ( mkQ (mempty, ) $ \x s -> case x of+                (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst ->+                  (s, s)+                L _ x' -> (mempty, Just *** Just $ needsParensSpace x')+            ) a+   in ( maybe True getAll needs_space+      , bool id maybeParensAST $ maybe False getAll needs_parens+      )+++------------------------------------------------------------------------------++graftExprWithM ::+    forall m a.+    (Fail.MonadFail m, Data a) =>+    SrcSpan ->+    (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) ->+    Graft m a+graftExprWithM dst trans = Graft $ \dflags a -> do+    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a++    everywhereM'+        ( mkM $+            \case+                val@(L src _ :: LHsExpr GhcPs)+                    | locA src `eqSrcSpan` dst -> do+                        mval <- trans val+                        case mval of+                            Just val' -> do+                                val'' <-+                                    hoistTransform (either Fail.fail pure)+                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))+                                pure val''+                            Nothing -> pure val+                l -> pure l+        )+        a++graftWithM ::+    forall ast m a l.+    (Fail.MonadFail m, Data a, ASTElement l ast) =>+    SrcSpan ->+    (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) ->+    Graft m a+graftWithM dst trans = Graft $ \dflags a -> do+    everywhereM'+        ( mkM $+            \case+                val@(L src _ :: LocatedAn l ast)+                    | locA src `eqSrcSpan` dst -> do+                        mval <- trans val+                        case mval of+                            Just val' -> do+                                val'' <-+                                    hoistTransform (either Fail.fail pure) $+                                        annotate dflags False $ maybeParensAST val'+                                pure val''+                            Nothing -> pure val+                l -> pure l+        )+        a++-- | Run the given transformation only on the smallest node in the tree that+-- contains the 'SrcSpan'.+genericGraftWithSmallestM ::+    forall m a ast.+    (Monad m, Data a, Typeable ast) =>+    -- | The type of nodes we'd like to consider when finding the smallest.+    Proxy (Located ast) ->+    SrcSpan ->+    (DynFlags -> ast -> GenericM (TransformT m)) ->+    Graft m a+genericGraftWithSmallestM proxy dst trans = Graft $ \dflags ->+    smallestM (genericIsSubspan proxy dst) (trans dflags)++-- | Run the given transformation only on the largest node in the tree that+-- contains the 'SrcSpan'.+genericGraftWithLargestM ::+    forall m a ast.+    (Monad m, Data a, Typeable ast) =>+    -- | The type of nodes we'd like to consider when finding the largest.+    Proxy (Located ast) ->+    SrcSpan ->+    (DynFlags -> ast -> GenericM (TransformT m)) ->+    Graft m a+genericGraftWithLargestM proxy dst trans = Graft $ \dflags ->+    largestM (genericIsSubspan proxy dst) (trans dflags)+++graftDecls ::+    forall a.+    (HasDecls a) =>+    SrcSpan ->+    [LHsDecl GhcPs] ->+    Graft (Either String) a+graftDecls dst decs0 = Graft $ \dflags a -> do+    decs <- forM decs0 $ \decl -> do+        annotateDecl dflags decl+    let go [] = DL.empty+        go (L src e : rest)+            | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest+            | otherwise = DL.singleton (L src e) <> go rest+    modifyDeclsT (pure . DL.toList . go) a+++-- | Replace the smallest declaration whose SrcSpan satisfies the given condition with a new+-- list of declarations.+--+-- For example, if you would like to move a where-clause-defined variable to the same+-- level as its parent HsDecl, you could use this function.+--+-- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. If+-- not declaration matched, then `Nothing` is returned.+modifySmallestDeclWithM ::+  forall a m r.+  (HasDecls a, Monad m) =>+  (SrcSpan -> m Bool) ->+  (LHsDecl GhcPs -> TransformT m ([LHsDecl GhcPs], r)) ->+  a ->+  TransformT m (a, Maybe r)+modifySmallestDeclWithM validSpan f a = do+  let modifyMatchingDecl [] = pure (DL.empty, Nothing)+      modifyMatchingDecl (ldecl@(L src _) : rest) =+        TransformT (lift $ validSpan $ locA src) >>= \case+            True -> do+              (decs', r) <- f ldecl+              pure (DL.fromList decs' <> DL.fromList rest, Just r)+            False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest+  modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a++generatedAnchor :: AnchorOperation -> Anchor+generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp++setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN+setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) =+  SrcSpanAnn (EpAnn anc nameAnn comments) span+setAnchor _ spanAnnN = spanAnnN++removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN+removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) =+  let nameAnnSansTrailings = nameAnn {nann_trailing = []}+  in SrcSpanAnn (EpAnn anc nameAnnSansTrailings comments) span+removeTrailingAnns spanAnnN = spanAnnN++-- | Modify the type signature for the given IdP. This function handles splitting a multi-sig+-- SigD into multiple SigD if the type signature is changed.+--+-- For example, update the type signature for `foo` from `Int` to `Bool`:+--+-- - foo :: Int+-- + foo :: Bool+--+-- - foo, bar :: Int+-- + bar :: Int+-- + foo :: Bool+--+-- - foo, bar, baz :: Int+-- + bar, baz :: Int+-- + foo :: Bool+modifySigWithM ::+  forall a m.+  (HasDecls a, Monad m) =>+  IdP GhcPs ->+  (LHsSigType GhcPs -> LHsSigType GhcPs) ->+  a ->+  TransformT m a+modifySigWithM queryId f a = do+  let modifyMatchingSigD :: [LHsDecl GhcPs] -> TransformT m (DL.DList (LHsDecl GhcPs))+      modifyMatchingSigD [] = pure DL.empty+      modifyMatchingSigD (ldecl@(L annSigD (SigD xsig (TypeSig xTypeSig ids (HsWC xHsWc lHsSig)))) : rest)+        | queryId `elem` (unLoc <$> ids) = do+            let newSig = f lHsSig+            -- If this signature update caused no change, then we don't need to split up multi-signatures+            if newSig `geq` lHsSig+              then pure $ DL.singleton ldecl <> DL.fromList rest+              else case partition ((== queryId) . unLoc) ids of+                ([L annMatchedId matchedId], otherIds) ->+                  let matchedId' = L (setAnchor genAnchor0 $ removeTrailingAnns annMatchedId) matchedId+                      matchedIdSig =+                        let sig' = SigD xsig (TypeSig xTypeSig [matchedId'] (HsWC xHsWc newSig))+                            epAnn = bool (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 0)) annSigD (null otherIds)+                        in L epAnn sig'+                      otherSig = case otherIds of+                        [] -> []+                        (L (SrcSpanAnn epAnn span) id1:ids) -> [+                          let epAnn' = case epAnn of+                                EpAnn _ nameAnn commentsId1 -> EpAnn genAnchor0 nameAnn commentsId1+                                EpAnnNotUsed -> EpAnn genAnchor0 mempty emptyComments+                              ids' = L (SrcSpanAnn epAnn' span) id1:ids+                              ids'' = ids' & _last %~ first removeTrailingAnns+                            in L annSigD (SigD xsig (TypeSig xTypeSig ids'' (HsWC xHsWc lHsSig)))+                            ]+                  in pure $ DL.fromList otherSig <> DL.singleton matchedIdSig <> DL.fromList rest+                _ -> error "multiple ids matched"+      modifyMatchingSigD (ldecl : rest) = (DL.singleton ldecl <>) <$> modifyMatchingSigD rest+  modifyDeclsT (fmap DL.toList . modifyMatchingSigD) a++genAnchor0 :: Anchor+genAnchor0 = generatedAnchor m0++genAnchor1 :: Anchor+genAnchor1 = generatedAnchor m1++-- | Apply a transformation to the decls contained in @t@+modifyDeclsT' :: (HasDecls t, HasTransform m)+             => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r))+             -> t -> m (t, r)+modifyDeclsT' action t = do+  decls <- liftT $ hsDecls t+  (decls', r) <- action decls+  t' <- liftT $ replaceDecls t decls'+  pure (t', r)++-- | Modify each LMatch in a MatchGroup+modifyMgMatchesT ::+  Monad m =>+  MatchGroup GhcPs (LHsExpr GhcPs) ->+  (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))) ->+  TransformT m (MatchGroup GhcPs (LHsExpr GhcPs))+modifyMgMatchesT mg f = fst <$> modifyMgMatchesT' mg (fmap (, ()) . f) () ((.) pure . const)++-- | Modify the each LMatch in a MatchGroup+modifyMgMatchesT' ::+  Monad m =>+  MatchGroup GhcPs (LHsExpr GhcPs) ->+  (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs), r)) ->+  r ->+  (r -> r -> m r) ->+  TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r)+#if MIN_VERSION_ghc(9,5,0)+modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do+  (unzip -> (matches', rs)) <- mapM f matches+  r' <- TransformT $ lift $ foldM combineResults def rs+  pure $ (MG xMg (L locMatches matches'), r')+#else+modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do+  (unzip -> (matches', rs)) <- mapM f matches+  r' <- lift $ foldM combineResults def rs+  pure (MG xMg (L locMatches matches') originMg, r')+#endif++graftSmallestDeclsWithM ::+    forall a.+    (HasDecls a) =>+    SrcSpan ->+    (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) ->+    Graft (Either String) a+graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do+    let go [] = pure DL.empty+        go (e@(L src _) : rest)+            | dst `isSubspanOf` locA src = toDecls e >>= \case+                Just decs0 -> do+                    decs <- forM decs0 $ \decl ->+                        annotateDecl dflags decl+                    pure $ DL.fromList decs <> DL.fromList rest+                Nothing -> (DL.singleton e <>) <$> go rest+            | otherwise = (DL.singleton e <>) <$> go rest+    modifyDeclsT (fmap DL.toList . go) a++graftDeclsWithM ::+    forall a m.+    (HasDecls a, Fail.MonadFail m) =>+    SrcSpan ->+    (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) ->+    Graft m a+graftDeclsWithM dst toDecls = Graft $ \dflags a -> do+    let go [] = pure DL.empty+        go (e@(L src _) : rest)+            | locA src `eqSrcSpan` dst = toDecls e >>= \case+                Just decs0 -> do+                    decs <- forM decs0 $ \decl ->+                        hoistTransform (either Fail.fail pure) $+                          annotateDecl dflags decl+                    pure $ DL.fromList decs <> DL.fromList rest+                Nothing -> (DL.singleton e <>) <$> go rest+            | otherwise = (DL.singleton e <>) <$> go rest+    modifyDeclsT (fmap DL.toList . go) a+++-- In 9.2+, we need `Default l` to do `setPrecedingLines` on annotated elements.+-- In older versions, we pass around annotations explicitly, so the instance isn't needed.+class+    ( Data ast+    , Typeable l+    , Outputable l+    , Outputable ast+    , Default l+    ) => ASTElement l ast | ast -> l where+    parseAST :: Parser (LocatedAn l ast)+    maybeParensAST :: LocatedAn l ast -> LocatedAn l ast+    {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with+        the given @Located ast@. The node at that position must already be+        a @Located ast@, or this is a no-op.+    -}+    graft ::+        forall a.+        (Data a) =>+        SrcSpan ->+        LocatedAn l ast ->+        Graft (Either String) a+    graft dst = graft' True dst . maybeParensAST++instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where+    parseAST = parseExpr+    maybeParensAST = parenthesize+    graft = graftExpr++instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where+    parseAST = parsePattern+    maybeParensAST = parenthesizePat appPrec++instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where+    parseAST = parseType+    maybeParensAST = parenthesizeHsType appPrec++instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where+    parseAST = parseDecl+    maybeParensAST = id++instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where+    parseAST = parseImport+    maybeParensAST = id++instance ASTElement NameAnn RdrName where+    parseAST df fp = parseWith df fp parseIdentifier+    maybeParensAST = id++------------------------------------------------------------------------------+++------------------------------------------------------------------------------+++-- | Given an 'LHSExpr', compute its exactprint annotations.+--   Note that this function will throw away any existing annotations (and format)+annotate :: ASTElement l ast+    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast)+annotate dflags needs_space ast = do+    uniq <- show <$> uniqueSrcSpanT+    let rendered = render dflags ast+#if MIN_VERSION_ghc(9,4,0)+    expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered+    pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space)+#else+    expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered+    pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space)+#endif++-- | Given an 'LHsDecl', compute its exactprint annotations.+annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)+annotateDecl dflags ast = do+    uniq <- show <$> uniqueSrcSpanT+    let rendered = render dflags ast+#if MIN_VERSION_ghc(9,4,0)+    expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered+    pure $ setPrecedingLines expr' 1 0+#else+    expr' <- lift $ mapLeft show $ parseDecl dflags uniq rendered+    pure $ setPrecedingLines expr' 1 0+#endif++------------------------------------------------------------------------------++-- | Print out something 'Outputable'.+render :: Outputable a => DynFlags -> a -> String+render dflags = showSDoc dflags . ppr++------------------------------------------------------------------------------++-- | Put parentheses around an expression if required.+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++-- | Equality on SrcSpan's.+-- Ignores the (Maybe BufSpan) field of SrcSpan's.+eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool+eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ++addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext+addParensToCtxt close_dp = addOpen . addClose+  where+      addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]}+      addOpen other                       = other+      addClose it+        | Just c <- close_dp = it{ac_close = [c]}+        | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]}+        | otherwise = it++epl :: Int -> EpaLocation+epl n = EpaDelta (SameLine n) []++epAnn :: SrcSpan -> ann -> EpAnn ann+epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments++modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast+modifyAnns x f = first ((fmap.fmap) f) x++removeComma :: SrcSpanAnnA -> SrcSpanAnnA+removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it+removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l)+  = SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l+  where+      isCommaAnn AddCommaAnn{} = True+      isCommaAnn _             = False++addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn+addParens True it@NameAnn{} =+        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }+addParens True it@NameAnnCommas{} =+        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }+addParens True it@NameAnnOnly{} =+        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }+addParens True NameAnnTrailing{..} =+        NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..}+addParens _ it = it++removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast+removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l++isCommaAnn :: TrailingAnn -> Bool+isCommaAnn AddCommaAnn{} = True+isCommaAnn _             = False
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -0,0 +1,2005 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE GADTs #-}++module Development.IDE.Plugin.CodeAction+    (+    mkExactprintPluginDescriptor,+    iePluginDescriptor,+    typeSigsPluginDescriptor,+    bindingsPluginDescriptor,+    fillHolePluginDescriptor,+    extendImportPluginDescriptor,+    -- * For testing+    matchRegExMultipleImports+    ) where++import           Control.Applicative                               ((<|>))+import           Control.Applicative.Combinators.NonEmpty          (sepBy1)+import           Control.Arrow                                     (second,+                                                                    (&&&),+                                                                    (>>>))+import           Control.Concurrent.STM.Stats                      (atomically)+import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           Control.Monad.Trans+import           Control.Monad.Trans.Except                        (ExceptT (ExceptT))+import           Control.Monad.Trans.Maybe+import           Data.Char+import qualified Data.DList                                        as DL+import           Data.Function+import           Data.Functor+import qualified Data.HashMap.Strict                               as Map+import qualified Data.HashSet                                      as Set+import           Data.List.Extra+import           Data.List.NonEmpty                                (NonEmpty ((:|)))+import qualified Data.List.NonEmpty                                as NE+import qualified Data.Map.Strict                                   as M+import           Data.Maybe+import           Data.Ord                                          (comparing)+import qualified Data.Set                                          as S+import qualified Data.Text                                         as T+import qualified Data.Text.Encoding                                as T+import           Development.IDE.Core.Rules+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Service+import           Development.IDE.Core.Shake                        hiding (Log)+import           Development.IDE.GHC.Compat                        hiding+                                                                   (ImplicitPrelude)+import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.Compat.Util+import           Development.IDE.GHC.Error+import           Development.IDE.GHC.ExactPrint+import qualified Development.IDE.GHC.ExactPrint                    as E+import           Development.IDE.GHC.Util                          (printOutputable,+                                                                    printRdrName)+import           Development.IDE.Plugin.CodeAction.Args+import           Development.IDE.Plugin.CodeAction.ExactPrint+import           Development.IDE.Plugin.CodeAction.PositionIndexed+import           Development.IDE.Plugin.CodeAction.Util+import           Development.IDE.Plugin.Completions.Types+import qualified Development.IDE.Plugin.Plugins.AddArgument+import           Development.IDE.Plugin.Plugins.Diagnostic+import           Development.IDE.Plugin.Plugins.FillHole           (suggestFillHole)+import           Development.IDE.Plugin.Plugins.FillTypeWildcard   (suggestFillTypeWildcard)+import           Development.IDE.Plugin.Plugins.ImportUtils+import           Development.IDE.Plugin.TypeLenses                 (suggestSignature)+import           Development.IDE.Types.Exports+import           Development.IDE.Types.Location+import           Development.IDE.Types.Options+import           GHC                                               (AddEpAnn (AddEpAnn),+                                                                    Anchor (anchor_op),+                                                                    AnchorOperation (..),+                                                                    AnnsModule (am_main),+                                                                    DeltaPos (..),+                                                                    EpAnn (..),+                                                                    EpaLocation (..),+                                                                    LEpaComment)+import           GHC.Exts                                          (fromList)+import qualified GHC.LanguageExtensions                            as Lang+import           Ide.Logger                                        hiding+                                                                   (group)+import           Ide.PluginUtils                                   (extendToFullLines,+                                                                    extractTextInRange,+                                                                    subRange)+import           Ide.Types+import           Language.LSP.Protocol.Message                     (Method (..),+                                                                    SMethod (..))+import           Language.LSP.Protocol.Types                       (ApplyWorkspaceEditParams (..),+                                                                    CodeAction (..),+                                                                    CodeActionKind (CodeActionKind_QuickFix),+                                                                    CodeActionParams (CodeActionParams),+                                                                    Command,+                                                                    Diagnostic (..),+                                                                    MessageType (..),+                                                                    Null (Null),+                                                                    ShowMessageParams (..),+                                                                    TextDocumentIdentifier (TextDocumentIdentifier),+                                                                    TextEdit (TextEdit, _range),+                                                                    UInt,+                                                                    WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),+                                                                    type (|?) (InL, InR),+                                                                    uriToFilePath)+import qualified Language.LSP.Server                               as LSP+import           Language.LSP.VFS                                  (virtualFileText)+import qualified Text.Fuzzy.Parallel                               as TFP+import qualified Text.Regex.Applicative                            as RE+import           Text.Regex.TDFA                                   ((=~), (=~~))++-------------------------------------------------------------------------------------------------++-- | Generate code actions.+codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do+  contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri+  liftIO $ do+    let text = virtualFileText <$> contents+        mbFile = toNormalizedFilePath' <$> uriToFilePath uri+    allDiags <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state+    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile+    let+      actions = caRemoveRedundantImports parsedModule text allDiags range uri+               <> caRemoveInvalidExports parsedModule text allDiags range uri+    pure $ InL actions++-------------------------------------------------------------------------------------------------++iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState+iePluginDescriptor recorder plId =+  let old =+        mkGhcideCAsPlugin [+            wrap suggestExportUnusedTopBinding+          , wrap suggestModuleTypo+          , wrap suggestFixConstructorImport+          , wrap suggestExtendImport+          , wrap suggestImportDisambiguation+          , wrap suggestNewOrExtendImportForClassMethod+          , wrap suggestHideShadow+          , wrap suggestNewImport+          , wrap suggestAddRecordFieldImport+          ]+          plId+          "Provides various quick fixes"+   in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler SMethod_TextDocumentCodeAction codeAction }++typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState+typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $+  mkGhcideCAsPlugin [+      wrap $ suggestSignature True+    , wrap suggestFillTypeWildcard+    , wrap suggestAddTypeAnnotationToSatisfyConstraints+    , wrap removeRedundantConstraints+    , wrap suggestConstraint+    ]+    plId+    "Provides various quick fixes for type signatures"++bindingsPluginDescriptor :: Recorder (WithPriority E.Log) ->  PluginId -> PluginDescriptor IdeState+bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $+  mkGhcideCAsPlugin [+      wrap suggestReplaceIdentifier+    , wrap suggestImplicitParameter+    , wrap suggestNewDefinition+    , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin+    , wrap suggestDeleteUnusedBinding+    ]+    plId+    "Provides various quick fixes for bindings"++fillHolePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState+fillHolePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder (mkGhcideCAPlugin (wrap suggestFillHole) plId "Provides a code action to fill a hole")++extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState+extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId "Provides a command to extend the import list")+  { pluginCommands = [extendImportCommand] }+++-- | Add the ability for a plugin to call GetAnnotatedParsedSource+mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a+mkExactprintPluginDescriptor recorder desc = desc { pluginRules = pluginRules desc >> getAnnotatedParsedSourceRule recorder }++-------------------------------------------------------------------------------------------------+++extendImportCommand :: PluginCommand IdeState+extendImportCommand =+  PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler++extendImportHandler :: CommandFunction IdeState ExtendImport+extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do+  res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit+  whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do+    let (_, head -> TextEdit {_range}) = fromJust $ _changes >>= listToMaybe . M.toList+        srcSpan = rangeToSrcSpan nfp _range+    LSP.sendNotification SMethod_WindowShowMessage $+      ShowMessageParams MessageType_Info $+        "Import "+          <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent+          <> "’ from "+          <> importName+          <> " (at "+          <> printOutputable srcSpan+          <> ")"+    void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+  return $ Right $ InR Null++extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit)+extendImportHandler' ideState ExtendImport {..}+  | Just fp <- uriToFilePath doc,+    nfp <- toNormalizedFilePath' fp =+    do+      (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $+        runAction "extend import" ideState $+          runMaybeT $ do+            -- We want accurate edits, so do not use stale data here+            msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp+            ps <- MaybeT $ use GetAnnotatedParsedSource nfp+            (_, contents) <- MaybeT $ use GetFileContents nfp+            return (msr, ps, contents)+      let df = ms_hspp_opts msrModSummary+          wantedModule = mkModuleName (T.unpack importName)+          wantedQual = mkModuleName . T.unpack <$> importQual+          existingImport = find (isWantedModule wantedModule wantedQual) msrImports+      case existingImport of+        Just imp -> do+            fmap (nfp,) $ liftEither $+              rewriteToWEdit df doc+                $+                  extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp)++        Nothing -> do+            let qns = (,) <$> importQual <*> Just (qualifiedImportStyle df)+                n = newImport importName sym qns False+                sym = if isNothing importQual then Just it else Nothing+                it = case thingParent of+                  Nothing -> newThing+                  Just p  -> p <> "(" <> newThing <> ")"+            t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents)+            return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc, [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})+  | otherwise =+    mzero++isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool+isWantedModule wantedModule Nothing (L _ it@ImportDecl{ ideclName+#if MIN_VERSION_ghc(9,5,0)+                                                      , ideclImportList = Just (Exactly, _)+#else+                                                      , ideclHiding = Just (False, _)+#endif+                                                      }) =+    not (isQualifiedImport it) && unLoc ideclName == wantedModule+isWantedModule wantedModule (Just qual) (L _ ImportDecl{ ideclAs, ideclName+#if MIN_VERSION_ghc(9,5,0)+                                                       , ideclImportList = Just (Exactly, _)+#else+                                                       , ideclHiding = Just (False, _)+#endif+                                                       }) =+    unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual)+isWantedModule _ _ _ = False+++liftMaybe :: Monad m => Maybe a -> MaybeT m a+liftMaybe a = MaybeT $ pure a++liftEither :: Monad m => Either e a -> MaybeT m a+liftEither (Left _)  = mzero+liftEither (Right x) = return x++-------------------------------------------------------------------------------------------------++findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)+findSigOfDecl pred decls =+  listToMaybe+    [ sig+      | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls,+        any (pred . unLoc) idsSig+    ]++findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p)+findSigOfDeclRanged range decls = do+  dec <- findDeclContainingLoc (_start range) decls+  case dec of+     L _ (SigD _ sig@TypeSig {})     -> Just sig+     L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind+     _                               -> Nothing++findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p)+findSigOfBind range bind =+    case bind of+      FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind))+      _          -> Nothing+  where+    findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p)+    findSigOfLMatch ls = do+      match <- findDeclContainingLoc (_start range) ls+      let grhs = m_grhss $ unLoc match+      msum+        [findSigOfBinds range (grhssLocalBinds grhs) -- where clause+        , do+#if MIN_VERSION_ghc(9,3,0)+          grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs)+#else+          grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)+#endif+          case unLoc grhs of+            GRHS _ _ bd -> findSigOfExpr (unLoc bd)+        ]++    findSigOfExpr :: HsExpr p -> Maybe (Sig p)+    findSigOfExpr = go+      where+#if MIN_VERSION_ghc(9,3,0)+        go (HsLet _ _ binds _ _) = findSigOfBinds range binds+#else+        go (HsLet _ binds _) = findSigOfBinds range binds+#endif+        go (HsDo _ _ stmts) = do+          stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts)+          case stmtlr of+            LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR+            _                         -> Nothing+        go _ = Nothing++findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p)+findSigOfBinds range = go+  where+    go (HsValBinds _ (ValBinds _ binds lsigs)) =+        case unLoc <$> findDeclContainingLoc (_start range) lsigs of+          Just sig' -> Just sig'+          Nothing -> do+            lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds)+            findSigOfBind range (unLoc lHsBindLR)+    go _ = Nothing++findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p)+findInstanceHead df instanceHead decls =+  listToMaybe+    [ hsib_body+      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls,+        showSDoc df (ppr hsib_body) == instanceHead+    ]++findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e)+findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)++-- Single:+-- This binding for ‘mod’ shadows the existing binding+--   imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40+--   (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing)+-- Multi:+--This binding for ‘pack’ shadows the existing bindings+--  imported from ‘Data.ByteString’ at B.hs:6:1-22+--  imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27+--  imported from ‘Data.Text’ at B.hs:7:1-16+suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]+suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}+  | Just [identifier, modName, s] <-+      matchRegexUnifySpaces+        _message+        "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" =+    suggests identifier modName s+  | Just [identifier] <-+      matchRegexUnifySpaces+        _message+        "This binding for ‘([^`]+)’ shadows the existing bindings",+    Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)",+    mods <- [(modName, s) | [_, modName, s] <- matched],+    result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),+    hideAll <- ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result) =+    result <> [hideAll]+  | otherwise = []+  where+    L _ HsModule {hsmodImports} = astA ps++    suggests identifier modName s+      | Just tcM <- mTcM,+        Just har <- mHar,+        [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack 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+          then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents+          else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl+      | otherwise = []++findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)+findImportDeclByModuleName decls modName = flip find decls $ \case+  (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName)++isTheSameLine :: SrcSpan -> SrcSpan -> Bool+isTheSameLine s1 s2+  | Just sl1 <- getStartLine s1,+    Just sl2 <- getStartLine s2 =+    sl1 == sl2+  | otherwise = False+  where+    getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x++isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool+isUnusedImportedId+  TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}}+  HAR {refMap}+  identifier+  modName+  importSpan+    | occ <- mkVarOcc identifier,+      impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods,+      Just rdrEnv <-+        listToMaybe+          [ imv_all_exports+            | ImportedModsVal {..} <- impModsVals,+              imv_name == mkModuleName modName,+              isTheSameLine imv_span importSpan+          ],+      [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ,+      importedIdentifier <- Right name,+      refs <- M.lookup importedIdentifier refMap =+      maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs+    | otherwise = False++suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}+--     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant+    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"+    , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports+    , Just c <- contents+    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings)+    , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)+    , not (null ranges')+    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]++-- File.hs:16:1: warning:+--     The import of `Data.List' is redundant+--       except perhaps to import instances from `Data.List'+--     To import instances alone, use: import Data.List()+    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)+        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]+    | otherwise = []++diagInRange :: Diagnostic -> Range -> Bool+diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange+  where+    -- Ensures the range captures full lines. Makes it easier to trigger the correct+    -- "remove redundant" code actions from anywhere on the offending line.+    extendedRange = extendToFullLines r++-- Note [Removing imports is preferred]+-- It's good to prefer the remove imports code action because an unused import+-- is likely to be removed and less likely the warning will be disabled.+-- Therefore actions to remove a single or all redundant imports should be+-- preferred, so that the client can prioritize them higher.+caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction]+caRemoveRedundantImports m contents allDiags contextRange uri+  | Just pm <- m,+    r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags,+    allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],+    caRemoveAll <- removeAll allEdits,+    ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange],+    not $ null ctxEdits,+    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits+      = caRemoveCtx ++ [caRemoveAll]+  | otherwise = []+  where+    removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [diagnostic] WorkspaceEdit{..} where+        _changes = Just $ M.singleton uri tedit+        _documentChanges = Nothing+        _changeAnnotations = Nothing+    removeAll tedit = InR $ CodeAction{..} where+        _changes = Just $ M.singleton uri tedit+        _title = "Remove all redundant imports"+        _kind = Just CodeActionKind_QuickFix+        _diagnostics = Nothing+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        -- See Note [Removing imports is preferred]+        _isPreferred = Just True+        _command = Nothing+        _disabled = Nothing+        _data_ = Nothing+        _changeAnnotations = Nothing++caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction]+caRemoveInvalidExports m contents allDiags contextRange uri+  | Just pm <- m,+    Just txt <- contents,+    txt' <- indexedByPosition $ T.unpack txt,+    r <- mapMaybe (groupDiag pm) allDiags,+    r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r,+    caRemoveCtx <- mapMaybe removeSingle r',+    allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges],+    allRanges' <- extend txt' allRanges,+    Just caRemoveAll <- removeAll allRanges',+    ctxEdits <- [ x | x@(_, d, _) <- r, d `diagInRange` contextRange],+    not $ null ctxEdits+      = caRemoveCtx ++ [caRemoveAll]+  | otherwise = []+  where+    extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges++    groupDiag pm dig+      | Just (title, ranges) <- suggestRemoveRedundantExport pm dig+      = Just (title, dig, ranges)+      | otherwise = Nothing++    removeSingle (_, _, []) = Nothing+    removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where+        tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges+        _changes = Just $ M.singleton uri tedit+        _title = title+        _kind = Just CodeActionKind_QuickFix+        _diagnostics = Just [diagnostic]+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        _command = Nothing+        -- See Note [Removing imports is preferred]+        _isPreferred = Just True+        _disabled = Nothing+        _data_ = Nothing+        _changeAnnotations = Nothing+    removeAll [] = Nothing+    removeAll ranges = Just $ InR $ CodeAction{..} where+        tedit = concatMap (\r -> [TextEdit r ""]) ranges+        _changes = Just $ M.singleton uri tedit+        _title = "Remove all redundant exports"+        _kind = Just CodeActionKind_QuickFix+        _diagnostics = Nothing+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        _command = Nothing+        -- See Note [Removing imports is preferred]+        _isPreferred = Just True+        _disabled = Nothing+        _data_ = Nothing+        _changeAnnotations = Nothing++suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range])+suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}+  | msg <- unifySpaces _message+  , Just export <- hsmodExports+  , Just exportRange <- getLocatedRange $ reLoc export+  , exports <- unLoc export+  , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg)+                         <|> (,[_range]) <$> matchExportItem msg+                         <|> (,[_range]) <$> matchDupExport msg+  , subRange _range exportRange+    = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges)+  where+    matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’"+    matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list"+    getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of+      []     -> (txt, [_range])+      ranges -> (txt, ranges)+suggestRemoveRedundantExport _ _ = Nothing++suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestDeleteUnusedBinding+  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}+  contents+  Diagnostic{_range=_range,..}+-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’+    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+    , Just indexedContent <- indexedByPosition . T.unpack <$> contents+      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)+        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])+    | otherwise = []+    where+      relatedRanges indexedContent name =+        concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls+      toRange = realSrcSpanToRange+      extendForSpaces = extendToIncludePreviousNewlineIfPossible++      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]+      findRelatedSpans+        indexedContent+        name+        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =+        case lname of+          (L nLoc _name) | isTheBinding nLoc ->+            let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig+                findSig _ = []+            in+              extendForSpaces indexedContent (toRange l) :+              concatMap (findSig . reLoc) hsmodDecls+          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpans _ _ _ = []++      extractNameAndMatchesFromFunBind+        :: HsBind GhcPs+        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])+      extractNameAndMatchesFromFunBind+        FunBind+          { fun_id=lname+          , fun_matches=MG {mg_alts=L _ matches}+          } = Just (reLoc lname, matches)+      extractNameAndMatchesFromFunBind _ = Nothing++      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]+      findRelatedSigSpan indexedContent name l sig =+        let maybeSpan = findRelatedSigSpan1 name sig+        in case maybeSpan of+          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int+          Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused+          _ -> []++      -- Second of the tuple means there is only one match+      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)+      findRelatedSigSpan1 name (TypeSig _ lnames _) =+        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames+        in case maybeIdx of+            Nothing -> Nothing+            Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True)+            Just idx ->+              let targetLname = getLoc $ reLoc $ lnames !! idx+                  startLoc = srcSpanStart targetLname+                  endLoc = srcSpanEnd targetLname+                  startLoc' = if idx == 0+                              then startLoc+                              else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1)+                  endLoc' = if idx == 0 && idx < length lnames - 1+                            then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1)+                            else endLoc+              in Just (mkSrcSpan startLoc' endLoc', False)+      findRelatedSigSpan1 _ _ = Nothing++      -- for where clause+      findRelatedSpanForMatch+        :: PositionIndexedString+        -> String+        -> LMatch GhcPs (LHsExpr GhcPs)+        -> [Range]+      findRelatedSpanForMatch+        indexedContent+        name+        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do+        let go bag lsigs =+                if isEmptyBag bag+                then []+                else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag+        case grhssLocalBinds of+          (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs+          _                                     -> []++      findRelatedSpanForHsBind+        :: PositionIndexedString+        -> String+        -> [LSig GhcPs]+        -> LHsBind GhcPs+        -> [Range]+      findRelatedSpanForHsBind+        indexedContent+        name+        lsigs+        (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =+        if isTheBinding (getLoc lname)+        then+          let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig+              findSig _ = []+          in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs+        else concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpanForHsBind _ _ _ _ = []++      isTheBinding :: SrcSpan -> Bool+      isTheBinding span = srcSpanToRange span == Just _range++      isSameName :: IdP GhcPs -> String -> Bool+      isSameName x name = T.unpack (printOutputable x) == name++data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll+  deriving (Eq)++getLocatedRange :: HasSrcSpan a => a -> Maybe Range+getLocatedRange = srcSpanToRange . getLoc++suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit)+suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}+-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’+-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’+-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’+  | Just source <- srcOpt+  , Just [_, name] <-+      matchRegexUnifySpaces+        _message+        ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’"+  , Just (exportType, _) <-+      find (matchWithDiagnostic _range . snd)+      . mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing)+      $ hsmodDecls+  , Just exports       <- fmap (fmap reLoc) . reLoc <$> hsmodExports+  , Just exportsEndPos <- _end <$> getLocatedRange exports+  , let name'          = printExport exportType name+        sep            = exportSep source $ map getLocatedRange <$> exports+        exportName     = case sep of+          Nothing -> (if needsComma source exports then ", " else "") <> name'+          Just  s -> s <> name'+        exportsEndPos' = exportsEndPos { _character = pred $ _character exportsEndPos }+        insertPos      = fromMaybe exportsEndPos' $ case (sep, unLoc exports) of+          (Just _, exports'@(_:_)) -> fmap _end . getLocatedRange $ last exports'+          _                        -> Nothing+  = Just ("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)+  | otherwise = Nothing+  where+    exportSep :: T.Text -> Located [Maybe Range] -> Maybe T.Text+    exportSep src (L (RealSrcSpan _ _) xs@(_ : tl@(_ : _))) =+      case mapMaybe (\(e, s) -> (,) <$> e <*> s) $ zip (fmap _end <$> xs) (fmap _start <$> tl) of+        []     -> Nothing+        bounds -> Just smallestSep+          where+            smallestSep+              = snd+              $ minimumBy (comparing fst)+              $ map (T.length &&& id)+              $ nubOrd+              $ map (\(prevEnd, nextStart) -> textInRange (Range prevEnd nextStart) src) bounds+    exportSep _   _ = Nothing++    -- We get the last export and the closing bracket and check for comma in that range.+    needsComma :: T.Text -> Located [Located (IE GhcPs)] -> Bool+    needsComma _ (L _ []) = False+    needsComma source (L (RealSrcSpan l _) exports) =+      let closeParen = _end $ realSrcSpanToRange l+          lastExport = fmap _end . getLocatedRange $ last exports+      in+      case lastExport of+        Just lastExport ->+          not $ T.any (== ',') $ textInRange (Range lastExport closeParen) source+        _ -> False+    needsComma _ _ = False++    opLetter :: T.Text+    opLetter = ":!#$%&*+./<=>?@\\^|-~"++    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text+    parenthesizeIfNeeds needsTypeKeyword x+      | T.any (c ==) opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <> ")"+      | otherwise = x+      where+        c = T.head x++    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool+    matchWithDiagnostic Range{_start=l,_end=r} x =+      let loc = fmap _start . getLocatedRange $ x+       in loc >= Just l && loc <= Just r++    printExport :: ExportsAs -> T.Text -> T.Text+    printExport ExportName x    = parenthesizeIfNeeds False x+    printExport ExportPattern x = "pattern " <> x+    printExport ExportFamily x  = parenthesizeIfNeeds True x+    printExport ExportAll x     = parenthesizeIfNeeds True x <> "(..)"++    isTopLevel :: SrcSpan -> Bool+    isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0++    exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs))+    exportsAs (ValD _ FunBind {fun_id})          = Just (ExportName, reLoc fun_id)+    exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id)+    exportsAs (TyClD _ SynDecl{tcdLName})      = Just (ExportName, reLoc tcdLName)+    exportsAs (TyClD _ DataDecl{tcdLName})     = Just (ExportAll, reLoc tcdLName)+    exportsAs (TyClD _ ClassDecl{tcdLName})    = Just (ExportAll, reLoc tcdLName)+    exportsAs (TyClD _ FamDecl{tcdFam})        = Just (ExportFamily, reLoc $ fdLName tcdFam)+    exportsAs _                                = Nothing++suggestAddTypeAnnotationToSatisfyConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestAddTypeAnnotationToSatisfyConstraints sourceOpt Diagnostic{_range=_range,..}+-- File.hs:52:41: warning:+--     * Defaulting the following constraint to type ‘Integer’+--        Num p0 arising from the literal ‘1’+--     * In the expression: 1+--       In an equation for ‘f’: f = 1+-- File.hs:52:41: warning:+--     * Defaulting the following constraints to type ‘[Char]’+--        (Show a0)+--          arising from a use of ‘traceShow’+--          at A.hs:228:7-25+--        (IsString a0)+--          arising from the literal ‘"debug"’+--          at A.hs:228:17-23+--     * In the expression: traceShow "debug" a+--       In an equation for ‘f’: f a = traceShow "debug" a+-- File.hs:52:41: warning:+--     * Defaulting the following constraints to type ‘[Char]’+--         (Show a0)+--          arising from a use of ‘traceShow’+--          at A.hs:255:28-43+--        (IsString a0)+--          arising from the literal ‘"test"’+--          at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43+--     * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’+--       In the expression: seq "test" seq "test" (traceShow "test")+--       In an equation for ‘f’:+--          f = seq "test" seq "test" (traceShow "test")+--+    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False)+                    <|> matchRegexUnifySpaces _message (pat False False False True)+                    <|> matchRegexUnifySpaces _message (pat False False False False)++            = codeEdit _range ty lit (makeAnnotatedLit ty lit)+    | Just source <- sourceOpt+    , Just [ty, lit, srcspan] <- matchRegexUnifySpaces _message (pat True True False False)+    , range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+                 [s] -> let x = realSrcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+                 _ -> error "bug in srcspan parser"+    = let lit' = makeAnnotatedLit ty lit;+          tir = textInRange range source+      in codeEdit range ty lit (T.replace lit lit' tir)+    | otherwise = []+    where+      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"+#if MIN_VERSION_ghc(9,4,0)+      pat multiple at inArg inExpr = T.concat [ ".*Defaulting the type variable "+                                       , ".*to type ‘([^ ]+)’ "+                                       , "in the following constraint"+                                       , if multiple then "s" else " "+                                       , ".*arising from the literal ‘(.+)’"+                                       , if inArg then ".+In the.+argument" else ""+                                       , if at then ".+at ([^ ]*)" else ""+                                       , if inExpr then ".+In the expression" else ""+                                       , ".+In the expression"+                                       ]+#else+      pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint"+                                       , if multiple then "s" else ""+                                       , " to type ‘([^ ]+)’ "+                                       , ".*arising from the literal ‘(.+)’"+                                       , if inArg then ".+In the.+argument" else ""+                                       , if at then ".+at ([^ ]*)" else ""+                                       , if inExpr then ".+In the expression" else ""+                                       , ".+In the expression"+                                       ]+#endif+      codeEdit range ty lit replacement =+        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"+            edits = [TextEdit range replacement]+        in  [( title, edits )]++-- | GHC strips out backticks in case of infix functions as well as single quote+--   in case of quoted name when using TemplateHaskellQuotes. Which is not desired.+--+-- For example:+-- 1.+--+-- @+-- File.hs:52:41: error:+--     * Variable not in scope:+--         suggestAcion :: Maybe T.Text -> Range -> Range+--     * Perhaps you meant ‘suggestAction’ (line 83)+-- File.hs:94:37: error:+--     Not in scope: ‘T.isPrfixOf’+--     Perhaps you meant one of these:+--       ‘T.isPrefixOf’ (imported from Data.Text),+--       ‘T.isInfixOf’ (imported from Data.Text),+--       ‘T.isSuffixOf’ (imported from Data.Text)+--     Module ‘Data.Text’ does not export ‘isPrfixOf’.+-- @+--+-- * action: \`suggestAcion\` will be renamed to \`suggestAction\` keeping back ticks around the function+--+-- 2.+--+-- @+-- import Language.Haskell.TH (Name)+-- foo :: Name+-- foo = 'bread+--+-- File.hs:8:7: error:+--     Not in scope: ‘bread’+--       * Perhaps you meant one of these:+--         ‘break’ (imported from Prelude), ‘read’ (imported from Prelude)+--       * In the Template Haskell quotation 'bread+-- @+--+-- * action: 'bread will be renamed to 'break keeping single quote on beginning of name+suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}+    | renameSuggestions@(_:_) <- extractRenamableTerms _message+        = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]+    | otherwise = []++suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range}+  | Just (name, typ) <- matchVariableNotInScope message =+      newDefinitionAction ideOptions parsedModule _range name typ+  | Just (name, typ) <- matchFoundHole message,+    [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name (Just typ) =+      [(label, mkRenameEdit contents _range name : newDefinitionEdits)]+  | otherwise = []+  where+    message = unifySpaces _message++newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])]+newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ+  | Range _ lastLineP : _ <-+      [ realSrcSpanToRange sp+        | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls,+          _start `isInsideSrcSpan` l+      ],+    nextLineP <- Position {_line = _line lastLineP + 1, _character = 0} =+      [ ( "Define " <> sig,+          [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]+        )+      ]+  | otherwise = []+  where+    colon = if optNewColonConvention then " : " else " :: "+    sig = name <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ)+    ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule++{- Handles two variants with different formatting++1. Could not find module ‘Data.Cha’+   Perhaps you meant Data.Char (from base-4.12.0.0)++2. Could not find module ‘Data.I’+   Perhaps you meant+      Data.Ix (from base-4.14.3.0)+      Data.Eq (from base-4.14.3.0)+      Data.Int (from base-4.14.3.0)+-}+suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)]+suggestModuleTypo Diagnostic{_range=_range,..}+    | "Could not find module" `T.isInfixOf` _message =+      case T.splitOn "Perhaps you meant" _message of+          [_, stuff] ->+              [ ("replace with " <> modul, TextEdit _range modul)+              | modul <- mapMaybe extractModule (T.lines stuff)+              ]+          _ -> []+    | otherwise = []+  where+    extractModule line = case T.words line of+        [modul, "(from", _] -> Just modul+        _                   -> Nothing++suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)]+suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}+    | Just [binding, mod, srcspan] <-+      matchRegexUnifySpaces _message+#if MIN_VERSION_ghc(9,7,0)+      "Add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\(at (.*)\\)\\."+#else+      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)\\."+#endif+    = suggestions hsmodImports binding mod srcspan+    | Just (binding, mod_srcspan) <-+      matchRegExMultipleImports _message+    = mod_srcspan >>= uncurry (suggestions hsmodImports binding)+    | otherwise = []+    where+        canUseDatacon = case extractNotInScopeName _message of+                            Just NotInScopeTypeConstructorOrClass{} -> False+                            _                                       -> True++        suggestions decls binding mod srcspan+          | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+                [s] -> let x = realSrcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+                _ -> error "bug in srcspan parser",+            Just decl <- findImportDeclByRange decls range,+            Just ident <- lookupExportMap binding mod+          = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod+              , quickFixImportKind' "extend" importStyle+              , uncurry extendImport (unImportStyle importStyle) decl+              )+            | importStyle <- NE.toList $ importStyles ident+            ]+          | otherwise = []+        lookupExportMap binding mod+          | let em = getExportsMap exportsMap+#if MIN_VERSION_ghc(9,7,0)+                match = mconcat $ lookupOccEnv_AllNameSpaces em (mkVarOrDataOcc binding)+#else+                match1 = lookupOccEnv em (mkVarOrDataOcc binding)+                match2 = lookupOccEnv em (mkTypeOcc binding)+          , Just match <- match1 <> match2+#endif+          -- Only for the situation that data constructor name is same as type constructor name,+          -- let ident with parent be in front of the one without.+          , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match)+          , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch+          , (ident:_) <- idents -- Ensure fallback while `idents` is empty+          = Just ident++            -- fallback to using GHC suggestion even though it is not always correct+          | otherwise+          = Just IdentInfo+                { name = mkVarOrDataOcc binding+                , parent = Nothing+                , identModuleName  = mkModuleNameFS $ mkFastStringByteString $ T.encodeUtf8 mod}++data HidingMode+    = HideOthers [ModuleTarget]+    | ToQualified+        Bool+        -- ^ Parenthesised?+        ModuleName++data ModuleTarget+    = ExistingImp (NonEmpty (LImportDecl GhcPs))+    | ImplicitPrelude [LImportDecl GhcPs]++targetImports :: ModuleTarget -> [LImportDecl GhcPs]+targetImports (ExistingImp ne)     = NE.toList ne+targetImports (ImplicitPrelude xs) = xs++oneAndOthers :: [a] -> [(a, [a])]+oneAndOthers = go+    where+        go []       = []+        go (x : xs) = (x, xs) : map (second (x :)) (go xs)++isPreludeImplicit :: DynFlags -> Bool+isPreludeImplicit = xopt Lang.ImplicitPrelude++-- | Suggests disambiguation for ambiguous symbols.+suggestImportDisambiguation ::+    DynFlags ->+    Maybe T.Text ->+    Annotated ParsedSource ->+    T.Text ->+    Diagnostic ->+    [(T.Text, [Either TextEdit Rewrite])]+suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..}+    | Just [ambiguous] <-+        matchRegexUnifySpaces+            _message+            "Ambiguous occurrence ‘([^’]+)’"+      , Just modules <-+            map last+                <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’"+      , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" =+        suggestions ambiguous modules (isJust local)+    | otherwise = []+    where+        L _ HsModule {hsmodImports} = astA ps++        locDic =+            fmap (NE.fromList . DL.toList) $+            Map.fromListWith (<>) $+                map+                    ( \i@(L _ idecl) ->+                        ( T.pack $ moduleNameString $ unLoc $ ideclName idecl+                        , DL.singleton i+                        )+                    )+                    hsmodImports+        toModuleTarget "Prelude"+            | isPreludeImplicit df+             = Just $ ImplicitPrelude $+                maybe [] NE.toList (Map.lookup "Prelude" locDic)+        toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic+        parensed =+            "(" `T.isPrefixOf` T.strip (textInRange _range txt)+        -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3]+        removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort+        hasDuplicate xs = length xs /= length (S.fromList xs)+        suggestions symbol mods local+          | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of+                                  Just targets -> suggestionsImpl symbol (map (, []) targets) local+                                  Nothing      -> []+          | otherwise         = case mapM toModuleTarget mods of+                                  Just targets -> suggestionsImpl symbol (oneAndOthers targets) local+                                  Nothing      -> []+        suggestionsImpl symbol targetsWithRestImports local =+            sortOn fst+            [ ( renderUniquify mode modNameText symbol False+              , disambiguateSymbol ps fileContents diag symbol mode+              )+            | (modTarget, restImports) <- targetsWithRestImports+            , let modName = targetModuleName modTarget+                  modNameText = T.pack $ moduleNameString modName+            , mode <-+                [ ToQualified parensed qual+                | ExistingImp imps <- [modTarget]+                {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -}+                -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation+                -- nubOrd can't be used since SrcSpan is intentionally no Ord+                , L _ qual <- nub $ mapMaybe (ideclAs . unLoc)+                    $ NE.toList imps+                ]+                ++ [ToQualified parensed modName+                    | any (occursUnqualified symbol . unLoc)+                        (targetImports modTarget)+                    || case modTarget of+                        ImplicitPrelude{} -> True+                        _                 -> False+                    ]+                ++ [HideOthers restImports | not (null restImports)]+            ] ++ [ ( renderUniquify mode T.empty symbol True+              , disambiguateSymbol ps fileContents diag symbol mode+              ) | local, not (null targetsWithRestImports)+                , let mode = HideOthers (uncurry (:) (head targetsWithRestImports))+            ]+        renderUniquify HideOthers {} modName symbol local =+            "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports"+        renderUniquify (ToQualified _ qual) _ symbol _ =+            "Replace with qualified: "+                <> T.pack (moduleNameString qual)+                <> "."+                <> symbol+suggestImportDisambiguation _ _ _ _ _ = []++occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool+occursUnqualified symbol ImportDecl{..}+    | isNothing ideclAs = Just False /=+            -- I don't find this particularly comprehensible,+            -- but HLint suggested me to do so...+#if MIN_VERSION_ghc(9,5,0)+        (ideclImportList <&> \(isHiding, L _ ents) ->+            let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents+            in (isHiding == EverythingBut) && not occurs || (isHiding == Exactly) && occurs+        )+#else+        (ideclHiding <&> \(isHiding, L _ ents) ->+            let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents+            in isHiding && not occurs || not isHiding && occurs+        )+#endif+occursUnqualified _ _ = False++symbolOccursIn :: T.Text -> IE GhcPs -> Bool+symbolOccursIn symb = any ((== symb). printOutputable) . ieNames++targetModuleName :: ModuleTarget -> ModuleName+targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"+targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =+    unLoc ideclName++disambiguateSymbol ::+    Annotated ParsedSource ->+    T.Text ->+    Diagnostic ->+    T.Text ->+    HidingMode ->+    [Either TextEdit Rewrite]+disambiguateSymbol ps fileContents Diagnostic {..} (T.unpack -> symbol) = \case+    (HideOthers hiddens0) ->+        [ Right $ hideSymbol symbol idecl+        | ExistingImp idecls <- hiddens0+        , idecl <- NE.toList idecls+        ]+            ++ mconcat+                [ if null imps+                    then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) ps fileContents+                    else Right . hideSymbol symbol <$> imps+                | ImplicitPrelude imps <- hiddens0+                ]+    (ToQualified parensed qualMod) ->+        let occSym = mkVarOcc symbol+            rdr = Qual qualMod occSym+         in Right <$> [ if parensed+                then Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->+                    liftParseAST @(HsExpr GhcPs) df $+                    T.unpack $ printOutputable $+                        HsVar @GhcPs noExtField $+                            reLocA $ L (mkGeneralSrcSpan  "") rdr+                else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->+                    liftParseAST @RdrName df $+                    T.unpack $ printOutputable $ L (mkGeneralSrcSpan  "") rdr+            ]++findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)+findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs++suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)]+suggestFixConstructorImport Diagnostic{_range=_range,..}+    -- ‘Success’ is a data constructor of ‘Result’+    -- To import it use+    -- import Data.Aeson.Types( Result( Success ) )+    -- or+    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)+    --+    -- On 9.8++    --+    -- In the import of ‘ModuleA’:+    -- an item called ‘Constructor’+    -- is exported, but it is a data constructor of+    -- ‘A’.+  | Just [constructor, typ] <-+    matchRegexUnifySpaces _message+#if MIN_VERSION_ghc(9,7,0)+    "an item called ‘([^’]*)’ is exported, but it is a data constructor of ‘([^’]*)’"+#else+    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"+#endif+  = let fixedImport = typ <> "(" <> constructor <> ")"+    in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]+  | otherwise = []++suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]+suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..}+  | Just fieldName <- findMissingField _message+  , Just (range, indent) <- newImportInsertRange ps fileContents+    = let qis = qualifiedImportStyle df+          suggestions = nubSortBy simpleCompareImportSuggestion (constructNewImportSuggestions exportsMap (Nothing, NotInScopeThing fieldName) Nothing qis)+      in map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions+  | otherwise = []+    where+      findMissingField :: T.Text -> Maybe T.Text+      findMissingField t =+        let+            hasfieldRegex = "((.+\\.)?HasField) \"(.+)\" ([^ ]+) ([^ ]+)"+            regex = "(No instance for|Could not deduce):? (\\(" <> hasfieldRegex <> "\\)|‘" <> hasfieldRegex <> "’|" <> hasfieldRegex <> ")"+            match = filter (/="") <$> matchRegexUnifySpaces t regex+        in case match of+               Just [_, _, _, _, fieldName, _, _] -> Just fieldName+               _                                  -> Nothing++-- | Suggests a constraint for a declaration for which a constraint is missing.+suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]+suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}+  | Just missingConstraint <- findMissingConstraint _message+  = let codeAction = if _message =~ ("the type signature for:" :: String)+                        then suggestFunctionConstraint df parsedModule+                        else suggestInstanceConstraint df parsedModule+     in codeAction diag missingConstraint+  | otherwise = []+    where+      findMissingConstraint :: T.Text -> Maybe T.Text+      findMissingConstraint t =+        let -- The regex below can be tested at:+            --   https://regex101.com/r/dfSivJ/1+            regex = "(No instance for|Could not deduce):? (\\((.+)\\)|‘(.+)’|.+) arising from" -- a use of / a do statement++            match = matchRegexUnifySpaces t regex++            -- For a string like:+            --   "Could not deduce: ?a::() arising from"+            -- The `matchRegexUnifySpaces` function returns two empty match+            -- groups at the end of the list. It's not clear why this is the+            -- case, so we select the last non-empty match group.+            getCorrectGroup = last . filter (/="")++        in getCorrectGroup <$> match++-- | Suggests a constraint for an instance declaration for which a constraint is missing.+suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]++suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint+  | Just instHead <- instanceHead+  = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)]+  | otherwise = []+    where+      instanceHead+        -- Suggests a constraint for an instance declaration with no existing constraints.+        -- • No instance for (Eq a) arising from a use of ‘==’+        --   Possible fix: add (Eq a) to the context of the instance declaration+        -- • In the expression: x == y+        --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y+        --   In the instance declaration for ‘Eq (Wrap a)’+        | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"+        , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls+        = Just instHead+        -- Suggests a constraint for an instance declaration with one or more existing constraints.+        -- • Could not deduce (Eq b) arising from a use of ‘==’+        --   from the context: Eq a+        --     bound by the instance declaration at /path/to/Main.hs:7:10-32+        --   Possible fix: add (Eq b) to the context of the instance declaration+        -- • In the second argument of ‘(&&)’, namely ‘x' == y'’+        --   In the expression: x == y && x' == y'+        --   In an equation for ‘==’:+        --       (Pair x x') == (Pair y y') = x == y && x' == y'+        | Just [instanceLineStr, constraintFirstCharStr]+            <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"+        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})})))+            <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls+        = Just hsib_body+        | otherwise+        = Nothing++      readPositionNumber :: T.Text -> UInt+      readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral++      actionTitle :: T.Text -> T.Text+      actionTitle constraint = "Add `" <> constraint+        <> "` to the context of the instance declaration"++suggestImplicitParameter ::+  ParsedSource ->+  Diagnostic ->+  [(T.Text, Rewrite)]+suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range}+  | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising",+    Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls,+    Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})})+      <- findSigOfDecl (== funId) hsmodDecls+    =+      [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)+        , appendConstraint (T.unpack implicitT) hsib_body)]+  | otherwise = []++findTypeSignatureName :: T.Text -> Maybe T.Text+findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head++-- | Suggests a constraint for a type signature with any number of existing constraints.+suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]++suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint+-- • No instance for (Eq a) arising from a use of ‘==’+--   Possible fix:+--     add (Eq a) to the context of+--       the type signature for:+--         eq :: forall a. a -> a -> Bool+-- • In the expression: x == y+--   In an equation for ‘eq’: eq x y = x == y++-- • Could not deduce (Eq b) arising from a use of ‘==’+--   from the context: Eq a+--     bound by the type signature for:+--                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool+--     at Main.hs:5:1-42+--   Possible fix:+--     add (Eq b) to the context of+--       the type signature for:+--         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool+-- • In the second argument of ‘(&&)’, namely ‘y == y'’+--   In the expression: x == x' && y == y'+--   In an equation for ‘eq’:+--       eq (Pair x y) (Pair x' y') = x == x' && y == y'+  | Just typeSignatureName <- findTypeSignatureName _message+  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})+    <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls+  , title <- actionTitle missingConstraint typeSignatureName+  = [(title, appendConstraint (T.unpack missingConstraint) sig)]+  | otherwise+  = []+    where+      actionTitle :: T.Text -> T.Text -> T.Text+      actionTitle constraint typeSignatureName = "Add `" <> constraint+        <> "` to the context of the type signature for `" <> typeSignatureName <> "`"++-- | Suggests the removal of a redundant constraint for a type signature.+removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]+removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..}+-- • Redundant constraint: Eq a+-- • In the type signature for:+--      foo :: forall a. Eq a => a -> a+-- • Redundant constraints: (Monoid a, Show a)+-- • In the type signature for:+--      foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool+  -- Account for both "Redundant constraint" and "Redundant constraints".+  | "Redundant constraint" `T.isInfixOf` _message+  , Just typeSignatureName <- findTypeSignatureName _message+  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})+    <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls+  , Just redundantConstraintList <- findRedundantConstraints _message+  , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig+      = [(actionTitle redundantConstraintList typeSignatureName, rewrite)]+  | otherwise = []+    where+      toRemove df list a = T.pack (showSDoc df (ppr a)) `elem` list++      parseConstraints :: T.Text -> [T.Text]+      parseConstraints t = t+        & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")+        <&> T.strip++      stripConstraintsParens :: T.Text -> T.Text+      stripConstraintsParens constraints =+        if "(" `T.isPrefixOf` constraints+           then constraints & T.drop 1 & T.dropEnd 1 & T.strip+           else constraints++{-+9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning:+    ⢠Redundant constraints: (Eq a, Show a)+    ⢠In the type signature for:+               foo :: forall a. (Eq a, Show a) => a -> Bool",++9.0: "message": "⢠Redundant constraints: (Eq a, Show a)+    ⢠In the type signature for:+           foo :: forall a. (Eq a, Show a) => a -> Bool",+-}+      findRedundantConstraints :: T.Text -> Maybe [T.Text]+      findRedundantConstraints t = t+        & T.lines+        -- In <9.2 it's the first line, in 9.2 it' the second line+        & take 2+        & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip)+        & listToMaybe+        <&> (head >>> parseConstraints)++      formatConstraints :: [T.Text] -> T.Text+      formatConstraints [] = ""+      formatConstraints [constraint] = constraint+      formatConstraints constraintList = constraintList+        & T.intercalate ", "+        & \cs -> "(" <> cs <> ")"++      actionTitle :: [T.Text] -> T.Text -> T.Text+      actionTitle constraintList typeSignatureName =+        "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `"+        <> formatConstraints constraintList+        <> "` from the context of the type signature for `" <> typeSignatureName <> "`"++-------------------------------------------------------------------------------------------------++suggestNewOrExtendImportForClassMethod :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]+suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message}+  | Just [methodName, className] <-+      matchRegexUnifySpaces+        _message+        "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’",+    idents <-+      maybe [] (Set.toList . Set.filter (\x -> fmap occNameText (parent x) == Just className)) $+        lookupOccEnv (getExportsMap packageExportsMap) (mkVarOrDataOcc methodName) =+    mconcat $ suggest <$> idents+  | otherwise = []+  where+    suggest identInfo+      | importStyle <- NE.toList $ importStyles identInfo,+        mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) =+        case mImportDecl of+          -- extend+          Just decl ->+            [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleText,+                quickFixImportKind' "extend" style,+                [Right $ uncurry extendImport (unImportStyle style) decl]+              )+              | style <- importStyle+            ]+          -- new+          _+            | Just (range, indent) <- newImportInsertRange ps fileContents+            ->+             (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$>+            [ (quickFixImportKind' "new" style, newUnqualImport moduleText rendered False)+              | style <- importStyle,+                let rendered = renderImportStyle style+            ]+              <> [(quickFixImportKind "new.all", newImportAll moduleText)]+            | otherwise -> []+        where moduleText = moduleNameText identInfo++suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]+suggestNewImport df packageExportsMap ps fileContents Diagnostic{..}+  | msg <- unifySpaces _message+  , Just thingMissing <- extractNotInScopeName msg+  , qual <- extractQualifiedModuleName msg+  , qual' <-+      extractDoesNotExportModuleName msg+        >>= (findImportDeclByModuleName hsmodImports . T.unpack)+        >>= ideclAs . unLoc+        <&> T.pack . moduleNameString . unLoc+  , -- tentative workaround for detecting qualification in GHC 9.4+    -- FIXME: We can delete this after dropping the support for GHC 9.4+    qualGHC94 <-+        guard (ghcVersion == GHC94)+            *> extractQualifiedModuleNameFromMissingName (extractTextInRange _range fileContents)+  , Just (range, indent) <- newImportInsertRange ps fileContents+  , extendImportSuggestions <- matchRegexUnifySpaces msg+#if MIN_VERSION_ghc(9,7,0)+    "Add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"+#else+    "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"+#endif+  = let qis = qualifiedImportStyle df+        -- FIXME: we can use thingMissing once the support for GHC 9.4 is dropped.+        -- In what fllows, @missing@ is assumed to be qualified name.+        -- @thingMissing@ is already as desired with GHC != 9.4.+        -- In GHC 9.4, however, GHC drops a module qualifier from a qualified symbol.+        -- Thus we need to explicitly concatenate qualifier explicity in GHC 9.4.+        missing+            | GHC94 <- ghcVersion+            , isNothing (qual <|> qual')+            , Just q <- qualGHC94 =+                qualify q thingMissing+            | otherwise = thingMissing+        suggestions = nubSortBy simpleCompareImportSuggestion+          (constructNewImportSuggestions packageExportsMap (qual <|> qual' <|> qualGHC94, missing) extendImportSuggestions qis) in+    map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions+  where+    qualify q (NotInScopeDataConstructor d) = NotInScopeDataConstructor (q <> "." <> d)+    qualify q (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (q <> "." <> d)+    qualify q (NotInScopeThing d) = NotInScopeThing (q <> "." <> d)++    L _ HsModule {..} = astA ps+suggestNewImport _ _ _ _ _ = []++{- |+Extracts qualifier of the symbol from the missing symbol.+Input must be either a plain qualified variable or possibly-parenthesized qualified binary operator (though no strict checking is done for symbol part).+This is only needed to alleviate the issue #3473.++FIXME: We can delete this after dropping the support for GHC 9.4++>>> extractQualifiedModuleNameFromMissingName "P.lookup"+Just "P"++>>> extractQualifiedModuleNameFromMissingName "ΣP3_'.σlookup"+Just "\931P3_'"++>>> extractQualifiedModuleNameFromMissingName "ModuleA.Gre_ekσ.goodδ"+Just "ModuleA.Gre_ek\963"++>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ.+)"+Just "ModuleA.Gre_ek\963"++>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ..|.)"+Just "ModuleA.Gre_ek\963"++>>> extractQualifiedModuleNameFromMissingName "A.B.|."+Just "A.B"+-}+extractQualifiedModuleNameFromMissingName :: T.Text -> Maybe T.Text+extractQualifiedModuleNameFromMissingName (T.strip -> missing)+    = T.pack <$> (T.unpack missing RE.=~ qualIdentP)+    where+        {-+        NOTE: Haskell 2010 allows /unicode/ upper & lower letters+        as a module name component; otoh, regex-tdfa only allows+        /ASCII/ letters to be matched with @[[:upper:]]@ and/or @[[:lower:]]@.+        Hence we use regex-applicative(-text) for finer-grained predicates.++        RULES (from [Section 10 of Haskell 2010 Report](https://www.haskell.org/onlinereport/haskell2010/haskellch10.html)):+            modid	→	{conid .} conid+            conid	→	large {small | large | digit | ' }+            small	→	ascSmall | uniSmall | _+            ascSmall	→	a | b | … | z+            uniSmall	→	any Unicode lowercase letter+            large	→	ascLarge | uniLarge+            ascLarge	→	A | B | … | Z+            uniLarge	→	any uppercase or titlecase Unicode letter+        -}++        qualIdentP = parensQualOpP <|> qualVarP+        parensQualOpP = RE.sym '(' *> modNameP <* RE.sym '.' <* RE.anySym <* RE.few RE.anySym <* RE.sym ')'+        qualVarP = modNameP <* RE.sym '.' <* RE.some RE.anySym+        conIDP = RE.withMatched $+            RE.psym isUpper+            *> RE.many+                (RE.psym $ \c -> c == '\'' || c == '_' || isUpper c || isLower c || isDigit c)+        modNameP = fmap snd $ RE.withMatched $ conIDP `sepBy1` RE.sym '.'+++constructNewImportSuggestions+  :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion]+constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion+  [ suggestion+  | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name+  , identInfo <- maybe [] Set.toList $ lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)+                                    <> lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name) -- look up the modified unknown name in the export map+  , canUseIdent thingMissing identInfo                                              -- check if the identifier information retrieved can be used+  , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules                 -- check if the module of the identifier is allowed+  , suggestion <- renderNewImport identInfo                                         -- creates a list of import suggestions for the retrieved identifier information+  ]+ where+  renderNewImport :: IdentInfo -> [ImportSuggestion]+  renderNewImport identInfo+    | Just q <- qual+    = [ImportSuggestion importanceScore (quickFixImportKind "new.qualified") (newQualImport m q qis)]+    | otherwise+    = [ImportSuggestion importanceScore (quickFixImportKind' "new" importStyle) (newUnqualImport m (renderImportStyle importStyle) False)+      | importStyle <- NE.toList $ importStyles identInfo] +++      [ImportSuggestion importanceScore (quickFixImportKind "new.all") (newImportAll m)]+    where+        -- The importance score takes 2 metrics into account. The first being the similarity using+        -- the Text.Fuzzy.Parallel.match function. The second is a factor of the relation between+        -- the modules prefix import suggestion and the unknown identifier names.+        importanceScore+          | Just q <- qual+          = let+              similarityScore = fromIntegral $ unpackMatchScore (TFP.match (T.toLower q) (T.toLower m)) :: Double+              (maxLength, minLength) = case (T.length q, T.length m) of+                 (la, lb)+                   | la >= lb -> (fromIntegral la, fromIntegral lb)+                   | otherwise -> (fromIntegral lb, fromIntegral la)+              lengthPenaltyFactor = 100 * minLength / maxLength+            in max 0 (floor (similarityScore * lengthPenaltyFactor))+          | otherwise+          = 0+          where+            unpackMatchScore pScore+              | Just score <- pScore = score+              | otherwise = 0+        m = moduleNameText identInfo++data ImportSuggestion = ImportSuggestion !Int !CodeActionKind !NewImport+  deriving ( Eq )++-- | Implements a lexicographic order for import suggestions that ignores the code action.+-- First it compares the importance score in DESCENDING order.+-- If the scores are equal it compares the import names alphabetical order.+--+-- TODO: this should be a correct Ord instance but CodeActionKind does not implement a Ord+-- which would lead to an unlawful Ord instance.+simpleCompareImportSuggestion :: ImportSuggestion -> ImportSuggestion -> Ordering+simpleCompareImportSuggestion (ImportSuggestion s1 _ i1) (ImportSuggestion s2 _ i2)+  = flip compare s1 s2 <> compare i1 i2++newtype NewImport = NewImport {unNewImport :: T.Text}+  deriving (Show, Eq, Ord)++newImportToEdit :: NewImport -> Annotated ParsedSource -> T.Text -> Maybe (T.Text, TextEdit)+newImportToEdit (unNewImport -> imp) ps fileContents+  | Just (range, indent) <- newImportInsertRange ps fileContents+  = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " "))+  | otherwise = Nothing++-- | Finds the next valid position for inserting a new import declaration+-- * If the file already has existing imports it will be inserted under the last of these,+-- it is assumed that the existing last import declaration is in a valid position+-- * If the file does not have existing imports, but has a (module ... where) declaration,+-- the new import will be inserted directly under this declaration (accounting for explicit exports)+-- * If the file has neither existing imports nor a module declaration,+-- the import will be inserted at line zero if there are no pragmas,+-- * otherwise inserted one line after the last file-header pragma+newImportInsertRange :: Annotated ParsedSource -> T.Text -> Maybe (Range, Int)+newImportInsertRange ps fileContents+  |  Just ((l, c), col) <- case hsmodImports of+      -- When there is no existing imports, we only cares about the line number, setting column and indent to zero.+      [] -> (\line -> ((line, 0), 0)) <$> findPositionNoImports ps fileContents+      _  -> findPositionFromImports (map reLoc hsmodImports) last+  , let insertPos = Position (fromIntegral l) (fromIntegral c)+    = Just (Range insertPos insertPos, col)+  | otherwise = Nothing+  where+    L _ HsModule {..} = astA ps++-- | Find the position for a new import when there isn't an existing one.+-- * If there is a module declaration, a new import should be inserted under the module declaration (including exports list)+-- * Otherwise, a new import should be inserted after any file-header pragma.+findPositionNoImports :: Annotated ParsedSource -> T.Text -> Maybe Int+findPositionNoImports ps fileContents =+    maybe (Just (findNextPragmaPosition fileContents)) (findPositionAfterModuleName ps) hsmodName+  where+    L _ HsModule {..} = astA ps++-- | find line number right after module ... where+findPositionAfterModuleName :: Annotated ParsedSource+                            -> LocatedA ModuleName+                            -> Maybe Int+findPositionAfterModuleName ps hsmodName' = do+    -- Note that 'where' keyword and comments are not part of the AST. They belongs to+    -- the exact-print information. To locate it, we need to find the previous AST node,+    -- calculate the gap between it and 'where', then add them up to produce the absolute+    -- position of 'where'.++    lineOffset <- whereKeywordLineOffset -- Calculate the gap before 'where' keyword.+    case prevSrcSpan of+        UnhelpfulSpan _ -> Nothing+        (RealSrcSpan prevSrcSpan' _) ->+            -- add them up produce the absolute location of 'where' keyword+            Just $ srcLocLine (realSrcSpanEnd prevSrcSpan') + lineOffset+  where+    L _ HsModule {..} = astA ps++    -- The last AST node before 'where' keyword. Might be module name or export list.+    prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports++    -- The relative position of 'where' keyword (in lines, relative to the previous AST node).+    -- The exact-print API changed a lot in ghc-9.2, so we need to handle it separately for different compiler versions.+    whereKeywordLineOffset :: Maybe Int+#if MIN_VERSION_ghc(9,5,0)+    whereKeywordLineOffset = case hsmodAnn hsmodExt of+#else+    whereKeywordLineOffset = case hsmodAnn of+#endif+        EpAnn _ annsModule _ -> do+            -- Find the first 'where'+            whereLocation <- fmap NE.head .  NE.nonEmpty . mapMaybe filterWhere .  am_main $ annsModule+            epaLocationToLine whereLocation+        EpAnnNotUsed -> Nothing+    filterWhere (AddEpAnn AnnWhere loc) = Just loc+    filterWhere _                       = Nothing++    epaLocationToLine :: EpaLocation -> Maybe Int+#if MIN_VERSION_ghc(9,5,0)+    epaLocationToLine (EpaSpan sp _)+      = Just . srcLocLine . realSrcSpanEnd $ sp+#else+    epaLocationToLine (EpaSpan sp)+      = Just . srcLocLine . realSrcSpanEnd $ sp+#endif+    epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments+    -- 'priorComments' contains the comments right before the current EpaLocation+    -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and+    -- the current AST node+    epaLocationToLine (EpaDelta (DifferentLine line _) priorComments) = Just (line + sumCommentsOffset priorComments)++    sumCommentsOffset :: [LEpaComment] -> Int+    sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine (anchor_op anchor))++    anchorOpLine :: AnchorOperation -> Int+    anchorOpLine UnchangedAnchor                      = 0+    anchorOpLine (MovedAnchor (SameLine _))           = 0+    anchorOpLine (MovedAnchor (DifferentLine line _)) = line++findPositionFromImports :: HasSrcSpan a => t -> (t -> a) -> Maybe ((Int, Int), Int)+findPositionFromImports hsField f = case getLoc (f hsField) of+  RealSrcSpan s _ ->+    let col = calcCol s+     in Just ((srcLocLine (realSrcSpanEnd s), col), col)+  _ -> Nothing+  where calcCol s = srcLocCol (realSrcSpanStart s) - 1++-- | Find the position one after the last file-header pragma+-- Defaults to zero if there are no pragmas in file+findNextPragmaPosition :: T.Text -> Int+findNextPragmaPosition contents = lineNumber+  where+    lineNumber = afterLangPragma . afterOptsGhc $ afterShebang+    afterLangPragma = afterPragma "LANGUAGE" contents'+    afterOptsGhc = afterPragma "OPTIONS_GHC" contents'+    afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0+    contents' = T.lines contents++afterPragma :: T.Text -> [T.Text] -> Int -> Int+afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum++lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int+lastLineWithPrefix p contents lineNum = max lineNum next+  where+    next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents++checkPragma :: T.Text -> T.Text -> Bool+checkPragma name = check+  where+    check l = isPragma l && getName l == name+    getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l+    isPragma = T.isPrefixOf "{-#"++-- | Construct an import declaration with at most one symbol+newImport+  :: T.Text -- ^ module name+  -> Maybe T.Text -- ^  the symbol+  -> Maybe (T.Text, QualifiedImportStyle) -- ^ qualified name and style+  -> Bool -- ^ the symbol is to be imported or hidden+  -> NewImport+newImport modName mSymbol mQualNameStyle hiding = NewImport impStmt+  where+     symImp+            | Just symbol <- mSymbol+              , symOcc <- mkVarOcc $ T.unpack symbol =+              " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")"+            | otherwise = ""+     impStmt =+       "import "+         <> qualifiedModName (snd <$> mQualNameStyle)+         <> (if hiding then " hiding" else "")+         <> symImp+         <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual+     mQual = fst <$> mQualNameStyle+     qualifiedModName Nothing                       = modName+     qualifiedModName (Just QualifiedImportPrefix)  = "qualified " <> modName+     qualifiedModName (Just QualifiedImportPostfix) = modName <> " qualified"+++newQualImport :: T.Text -> T.Text -> QualifiedImportStyle -> NewImport+newQualImport modName qual qis = newImport modName Nothing (Just (qual, qis)) False++newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport+newUnqualImport modName symbol = newImport modName (Just symbol) Nothing++newImportAll :: T.Text -> NewImport+newImportAll modName = newImport modName Nothing Nothing False++hideImplicitPreludeSymbol :: T.Text -> NewImport+hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True++canUseIdent :: NotInScope -> IdentInfo -> Bool+canUseIdent NotInScopeDataConstructor{}        = isDatacon+canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon+canUseIdent _                                  = const True++data NotInScope+    = NotInScopeDataConstructor T.Text+    | NotInScopeTypeConstructorOrClass T.Text+    | NotInScopeThing T.Text+    deriving Show++notInScope :: NotInScope -> T.Text+notInScope (NotInScopeDataConstructor t)        = t+notInScope (NotInScopeTypeConstructorOrClass t) = t+notInScope (NotInScopeThing t)                  = t++extractNotInScopeName :: T.Text -> Maybe NotInScope+extractNotInScopeName x+  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"+  = Just $ NotInScopeDataConstructor name+  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"+  = Just $ NotInScopeDataConstructor name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"+  = Just $ NotInScopeTypeConstructorOrClass name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"+  = Just $ NotInScopeThing name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"+  = Just $ NotInScopeThing name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"+  = Just $ NotInScopeThing name+  | otherwise+  = Nothing++extractQualifiedModuleName :: T.Text -> Maybe T.Text+extractQualifiedModuleName x+  | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"+  = Just m+  | otherwise+  = Nothing++-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules+-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier+-- from the imported one.+--+-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s):+-- 1.+-- import qualified Data.Text as T+--+-- Module ‘Data.Text’ does not export ‘putStrLn’.+--+-- 2.+-- import qualified Data.Text as T+-- import qualified Data.Functor as T+--+-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.+--+-- 3.+-- import qualified Data.Text as T+-- import qualified Data.Functor as T+-- import qualified Data.Function as T+--+-- Neither ‘Data.Function’,+--         ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.+extractDoesNotExportModuleName :: T.Text -> Maybe T.Text+extractDoesNotExportModuleName x+  | Just [m] <-+#if MIN_VERSION_ghc(9,4,0)+    matchRegexUnifySpaces x "the module ‘([^’]*)’ does not export"+      <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ export"+#else+    matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export"+      <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"+#endif+  = Just m+  | otherwise+  = Nothing+-------------------------------------------------------------------------------------------------+++mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit+mkRenameEdit contents range name+    | maybeIsInfixFunction == Just True = TextEdit range ("`" <> name <> "`")+    | maybeIsTemplateFunction == Just True = TextEdit range ("'" <> name)+    | otherwise = TextEdit range name+  where+    maybeIsInfixFunction = do+      curr <- textInRange range <$> contents+      pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr+    maybeIsTemplateFunction = do+      curr <- textInRange range <$> contents+      pure $ "'" `T.isPrefixOf` curr++extractRenamableTerms :: T.Text -> [T.Text]+extractRenamableTerms msg+  -- Account for both "Variable not in scope" and "Not in scope"+  | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg+  | otherwise = []+  where+    extractSuggestions = map getEnclosed+                       . concatMap singleSuggestions+                       . filter isKnownSymbol+                       . T.lines+    singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited+    isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t+    getEnclosed = T.dropWhile (== '‘')+                . T.dropWhileEnd (== '’')+                . T.dropAround (\c -> c /= '‘' && c /= '’')++-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace+-- between the end of the range and the next newline), extend the range to take up the whole line.+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range+extendToWholeLineIfPossible contents range@Range{..} =+    let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents+        extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line+    in if extend then Range _start (Position (_line _end + 1) 0) else range++splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)+splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x+    | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x+    , (preCol, postCol) <- T.splitAt col mid+        = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)+    | otherwise = (x, T.empty)++-- | Returns [start .. end[+textInRange :: Range -> T.Text -> T.Text+textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =+    case compare startRow endRow of+      LT ->+        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine+            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of+              [] -> ("", [])+              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)+            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines+        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)+      EQ ->+        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)+        in T.take (endCol - startCol) (T.drop startCol line)+      GT -> ""+    where+      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)++-- | Returns the ranges for a binding in an import declaration+rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]+#if MIN_VERSION_ghc(9,5,0)+rangesForBindingImport ImportDecl{+  ideclImportList = Just (Exactly, L _ lies)+  } b =+    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies+  where+    b' = wrapOperatorInParens b+#else+rangesForBindingImport ImportDecl{+  ideclHiding = Just (False, L _ lies)+  } b =+    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies+  where+    b' = wrapOperatorInParens b+#endif+rangesForBindingImport _ _ = []++wrapOperatorInParens :: String -> String+wrapOperatorInParens x =+  case uncons x of+    -- see #2483 and #2859+    -- common lens functions use the _ prefix, and should not be wrapped in parens+    Just ('_', _t) -> x+    Just (h, _t)   -> if isAlpha h then x else "(" <> x <> ")"+    Nothing        -> mempty++smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range]+smallerRangesForBindingExport lies b =+    concatMap (mapMaybe srcSpanToRange . ranges') lies+  where+    unqualify = snd . breakOnEnd "."+    b' = wrapOperatorInParens . unqualify $ b+    ranges' (L _ (IEThingWith _ thing _  inners))+      | T.unpack (printOutputable thing) == b' = []+      | otherwise =+          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']+    ranges' _ = []++rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]+rangesForBinding' b (L (locA -> l) (IEVar _ nm))+  | L _ (IEPattern _ (L _ b')) <- nm+  , T.unpack (printOutputable b') == b+  = [l]+rangesForBinding' b (L (locA -> l) x@IEVar{})+  | T.unpack (printOutputable x) == b = [l]+rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l]+rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l]+rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners))+    | T.unpack (printOutputable thing) == b = [l]+    | otherwise =+        [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b]+rangesForBinding' _ _ = []++-- | 'allMatchRegex' combined with 'unifySpaces'+allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]]+allMatchRegexUnifySpaces message =+    allMatchRegex (unifySpaces message)++-- | Returns Just (all matches) for the first capture, or Nothing.+allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]]+allMatchRegex message regex = message =~~ regex+++-- functions to help parse multiple import suggestions++-- | Returns the first match if found+regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text+regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of+    Just (h:_) -> Just h+    _          -> Nothing++-- | Process a list of (module_name, filename:src_span) values+-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]+regExImports :: T.Text -> Maybe [(T.Text, T.Text)]+regExImports msg+    | Just mods' <- allMatchRegex msg "‘([^’]*)’"+    , Just srcspans' <- allMatchRegex msg+#if MIN_VERSION_ghc(9,7,0)+                          "\\(at ([^)]*)\\)"+#else+                          "\\(([^)]*)\\)"+#endif+    , mods <- [mod | [_,mod] <- mods']+    , srcspans <- [srcspan | [_,srcspan] <- srcspans']+      -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))+    , let result = if length mods == length srcspans then+                   Just (zip mods srcspans) else Nothing+    = result+    | otherwise = Nothing++matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])+matchRegExMultipleImports message = do+#if MIN_VERSION_ghc(9,7,0)+  let pat = T.pack "Add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"+#else+  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"+#endif+  (binding, imports) <- case matchRegexUnifySpaces message pat of+                            Just [x, xs] -> Just (x, xs)+                            _            -> Nothing+  imps <- regExImports imports+  return (binding, imps)
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -0,0 +1,291 @@+module Development.IDE.Plugin.CodeAction.Args+  ( CodeActionTitle,+    CodeActionPreferred,+    GhcideCodeActionResult,+    GhcideCodeAction,+    mkGhcideCAPlugin,+    mkGhcideCAsPlugin,+    ToTextEdit (..),+    ToCodeAction (..),+    wrap,+    mkCA,+  )+where++import           Control.Concurrent.STM.Stats                 (readTVarIO)+import           Control.Monad.Except                         (ExceptT (..),+                                                               runExceptT)+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe+import           Data.Either                                  (fromRight,+                                                               partitionEithers)+import           Data.Functor                                 ((<&>))+import           Data.IORef.Extra+import qualified Data.Map                                     as Map+import           Data.Maybe                                   (fromMaybe)+import qualified Data.Text                                    as T+import           Development.IDE                              hiding+                                                              (pluginHandlers)+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.ExactPrint+import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,+                                                               rewriteToEdit)+import           Development.IDE.Plugin.TypeLenses            (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),+                                                               GlobalBindingTypeSigsResult)+import           Development.IDE.Spans.LocalBindings          (Bindings)+import           Development.IDE.Types.Exports                (ExportsMap)+import           Development.IDE.Types.Options                (IdeOptions)+import           Ide.Plugin.Error                             (PluginError)+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Server                          as LSP++type CodeActionTitle = T.Text++type CodeActionPreferred = Bool++type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])]++type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCodeActionResult++-------------------------------------------------------------------------------------------------++runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult+runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do+  let mbFile = toNormalizedFilePath' <$> uriToFilePath uri+      runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key+  caaGhcSession <- onceIO $ runRule GhcSession+  caaExportsMap <-+    onceIO $+      caaGhcSession >>= \case+        Just env -> do+          pkgExports <- envPackageExports env+          localExports <- readTVarIO (exportsMap $ shakeExtras state)+          pure $ localExports <> pkgExports+        _ -> pure mempty+  caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions+  caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments+  caaContents <-+    onceIO $+      runRule GetFileContents <&> \case+        Just (_, txt) -> txt+        Nothing       -> Nothing+  caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule+  caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource+  caaTmr <- onceIO $ runRule TypeCheck+  caaHar <- onceIO $ runRule GetHieAst+  caaBindings <- onceIO $ runRule GetBindings+  caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs+  results <- liftIO $+      sequence+        [ runReaderT (runExceptT codeAction) CodeActionArgs {..}+          | caaDiagnostic <- diags+        ]+  let (_errs, successes) = partitionEithers results+  pure $ concat successes++mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)+mkCA title kind isPreferred diags edit =+  InR $ CodeAction title kind (Just diags) isPreferred Nothing (Just edit) Nothing Nothing++mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> T.Text -> PluginDescriptor IdeState+mkGhcideCAPlugin codeAction plId desc =+  (defaultPluginDescriptor plId desc)+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction $+        \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = diags}) -> do+          results <- lift $ runGhcideCodeAction state params codeAction+          pure $+              InL+                [ mkCA title kind isPreferred diags edit+                  | (title, kind, isPreferred, tedit) <- results,+                    let edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing+                ]+    }++mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> T.Text -> PluginDescriptor IdeState+mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions++-------------------------------------------------------------------------------------------------++class ToTextEdit a where+  toTextEdit :: CodeActionArgs -> a -> IO [TextEdit]++instance ToTextEdit TextEdit where+  toTextEdit _ = pure . pure++instance ToTextEdit Rewrite where+  toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $+    runMaybeT $ do+      df <- MaybeT caaDf+      let r = rewriteToEdit df rw+      pure $ fromRight [] r++instance ToTextEdit a => ToTextEdit [a] where+  toTextEdit caa = foldMap (toTextEdit caa)++instance ToTextEdit a => ToTextEdit (Maybe a) where+  toTextEdit caa = maybe (pure []) (toTextEdit caa)++instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where+  toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)++-------------------------------------------------------------------------------------------------++data CodeActionArgs = CodeActionArgs+  { caaExportsMap   :: IO ExportsMap,+    caaGhcSession   :: IO (Maybe HscEnvEq),+    caaIdeOptions   :: IO IdeOptions,+    caaParsedModule :: IO (Maybe ParsedModule),+    caaContents     :: IO (Maybe T.Text),+    caaDf           :: IO (Maybe DynFlags),+    caaAnnSource    :: IO (Maybe (Annotated ParsedSource)),+    caaTmr          :: IO (Maybe TcModuleResult),+    caaHar          :: IO (Maybe HieAstResult),+    caaBindings     :: IO (Maybe Bindings),+    caaGblSigs      :: IO (Maybe GlobalBindingTypeSigsResult),+    caaDiagnostic   :: Diagnostic+  }++-- | There's no concurrency in each provider,+-- so we don't need to be thread-safe here+onceIO :: MonadIO m => IO a -> m (IO a)+onceIO io = do+  var <- liftIO $ newIORef Nothing+  pure $+    readIORef var >>= \case+      Just x -> pure x+      _      -> io >>= \x -> writeIORef' var (Just x) >> pure x++-------------------------------------------------------------------------------------------------++wrap :: (ToCodeAction a) => a -> GhcideCodeAction+wrap = toCodeAction++class ToCodeAction a where+  toCodeAction :: a -> GhcideCodeAction++instance ToCodeAction GhcideCodeAction where+  toCodeAction = id++instance Semigroup GhcideCodeAction where+  a <> b = toCodeAction [a, b]++instance Monoid GhcideCodeAction where+  mempty = pure []++instance ToCodeAction a => ToCodeAction [a] where+  toCodeAction = fmap concat . mapM toCodeAction++instance ToCodeAction a => ToCodeAction (Maybe a) where+  toCodeAction = maybe (pure []) toCodeAction++instance ToCodeAction a => ToCodeAction (Either PluginError a) where+  toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction++instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where+  toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Nothing,) <$> toTextEdit caa te++instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where+  toCodeAction (title, kind, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Nothing,) <$> toTextEdit caa te++instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where+  toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Just isPreferred,) <$> toTextEdit caa te++instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where+  toCodeAction (title, kind, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te++-------------------------------------------------------------------------------------------------++toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction+toCodeAction1 get f = ExceptT . ReaderT $ \caa -> do+                          caaMay <- get caa+                          flip runReaderT caa . runExceptT . toCodeAction . f $ caaMay++toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction+toCodeAction2 get f = ExceptT . ReaderT $ \caa ->+  get caa >>= \case+    Just x -> flip runReaderT caa . runExceptT . toCodeAction . f $ x+    _      -> pure $ Right []++toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction+toCodeAction3 get f = ExceptT . ReaderT $ \caa -> get caa >>= flip runReaderT caa . runExceptT . toCodeAction . f++-- | this instance returns a delta AST, useful for exactprint transforms+instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where+#if !MIN_VERSION_ghc(9,3,0)+  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->+    x >>= \case+      Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s+      _      -> pure $ Right []+#else+  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} ->+    x >>= \case+      Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . pm_parsed_source $ s+      _      -> pure $ Right []+#endif++instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where+  toCodeAction = toCodeAction3 caaExportsMap++instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where+  toCodeAction = toCodeAction3 caaIdeOptions++instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where+  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x++instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where+  toCodeAction = toCodeAction1 caaParsedModule++instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where+  toCodeAction = toCodeAction2 caaParsedModule++instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where+  toCodeAction = toCodeAction1 caaContents++instance ToCodeAction r => ToCodeAction (T.Text -> r) where+  toCodeAction = toCodeAction2 caaContents++instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where+  toCodeAction = toCodeAction1 caaDf++instance ToCodeAction r => ToCodeAction (DynFlags -> r) where+  toCodeAction = toCodeAction2 caaDf++instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where+  toCodeAction = toCodeAction1 caaAnnSource++instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where+  toCodeAction = toCodeAction2 caaAnnSource++instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where+  toCodeAction = toCodeAction1 caaTmr++instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where+  toCodeAction = toCodeAction2 caaTmr++instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where+  toCodeAction = toCodeAction1 caaHar++instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where+  toCodeAction = toCodeAction2 caaHar++instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where+  toCodeAction = toCodeAction1 caaBindings++instance ToCodeAction r => ToCodeAction (Bindings -> r) where+  toCodeAction = toCodeAction2 caaBindings++instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where+  toCodeAction = toCodeAction1 caaGblSigs++instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where+  toCodeAction = toCodeAction2 caaGblSigs++instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where+  toCodeAction = toCodeAction1 caaGhcSession++instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where+  toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession)
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE GADTs        #-}+{-# LANGUAGE TypeFamilies #-}+module Development.IDE.Plugin.CodeAction.ExactPrint (+  Rewrite (..),+  rewriteToEdit,+  rewriteToWEdit,++  -- * Utilities+  appendConstraint,+  removeConstraint,+  extendImport,+  hideSymbol,+  liftParseAST,++  wildCardSymbol+) where++import           Control.Monad+import           Control.Monad.Trans+import           Data.Char                              (isAlphaNum)+import           Data.Data                              (Data)+import           Data.Generics                          (listify)+import qualified Data.Text                              as T+import           Development.IDE.GHC.Compat             hiding (Annotation)+import           Development.IDE.GHC.Error+import           Development.IDE.GHC.ExactPrint+import           Development.IDE.GHC.Util+import           Development.IDE.Spans.Common+import           GHC.Exts                               (IsList (fromList))+import           GHC.Stack                              (HasCallStack)+import           Language.Haskell.GHC.ExactPrint+import           Language.LSP.Protocol.Types++import           Development.IDE.Plugin.CodeAction.Util++-- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports.+import           Control.Lens                           (_head, _last, over)+import           Data.Bifunctor                         (first)+import           Data.Default                           (Default (..))+import           Data.Maybe                             (fromJust, fromMaybe,+                                                         mapMaybe)+import           GHC                                    (AddEpAnn (..),+                                                         AnnContext (..),+                                                         AnnList (..),+                                                         AnnParen (..),+                                                         DeltaPos (SameLine),+                                                         EpAnn (..),+                                                         EpaLocation (EpaDelta),+                                                         IsUnicodeSyntax (NormalSyntax),+                                                         NameAdornment (NameParens),+                                                         TrailingAnn (AddCommaAnn),+                                                         addAnns, ann,+                                                         emptyComments, reAnnL)+++------------------------------------------------------------------------------++-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the+--   given 'ast'.+data Rewrite where+  Rewrite ::+    (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) =>+    -- | The 'SrcSpan' that we want to rewrite+    SrcSpan ->+    -- | The ast that we want to graft+    (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) ->+    Rewrite++------------------------------------------------------------------------------+class ResetEntryDP ann where+    resetEntryDP :: GenLocated ann ast -> GenLocated ann ast+instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where+    -- resetEntryDP = flip setEntryDP (SameLine 0)+    resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0)+instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where+    resetEntryDP = id++-- | Convert a 'Rewrite' into a list of '[TextEdit]'.+rewriteToEdit :: HasCallStack =>+  DynFlags ->+  Rewrite ->+  Either String [TextEdit]+rewriteToEdit dflags+              (Rewrite dst f) = do+  (ast, _ , _) <- runTransformT+                          $ do+    ast <- f dflags+    pure $ traceAst "REWRITE_result" $ resetEntryDP ast+  let editMap =+        [ TextEdit (fromJust $ srcSpanToRange dst) $+            T.pack $ exactPrint ast+        ]+  pure editMap++-- | Convert a 'Rewrite' into a 'WorkspaceEdit'+rewriteToWEdit :: DynFlags+               -> Uri+               -> Rewrite+               -> Either String WorkspaceEdit+rewriteToWEdit dflags uri+               r = do+  edits <- rewriteToEdit dflags+                         r+  return $+    WorkspaceEdit+      { _changes = Just (fromList [(uri, edits)])+      , _documentChanges = Nothing+      , _changeAnnotations = Nothing+      }++------------------------------------------------------------------------------+++dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass)+dropHsParTy (L _ (HsParTy _ ty)) = ty+dropHsParTy other                = other++removeConstraint ::+  -- | Predicate: Which context to drop.+  (LHsType GhcPs -> Bool) ->+  LHsType GhcPs ->+  Rewrite+removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"+  where+    go :: LHsType GhcPs -> Rewrite+#if !MIN_VERSION_ghc(9,4,0)+    go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do+#else+    go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do+#endif+      let ctxt' = filter (not . toRemove) ctxt+          removeStuff = (toRemove <$> headMaybe ctxt) == Just True+      let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body+      return $ case ctxt' of+          [] -> hst_body'+          _ -> do+            let ctxt'' = over _last (first removeComma) ctxt'+#if MIN_VERSION_ghc(9,4,0)+            L l $ it{ hst_ctxt = L l' ctxt''+#else+            L l $ it{ hst_ctxt = Just $ L l' ctxt''+#endif+                    , hst_body = hst_body'+                    }+    go (L _ (HsParTy _ ty)) = go ty+    go (L _ HsForAllTy{hst_body}) = go hst_body+    go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other++-- | Append a constraint at the end of a type context.+--   If no context is present, a new one will be created.+appendConstraint ::+  -- | The new constraint to append+  String ->+  -- | The type signature where the constraint is to be inserted, also assuming annotated+  LHsType GhcPs ->+  Rewrite+appendConstraint constraintT = go . traceAst "appendConstraint"+ where+#if MIN_VERSION_ghc(9,4,0)+  go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do+#else+  go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do+#endif+    constraint <- liftParseAST df constraintT+    constraint <- pure $ setEntryDP constraint (SameLine 1)+    let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'+    -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint+    -- we have to reposition it manually into the AnnContext+        close_dp = case ctxt of+            [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close+            _ -> Nothing+        ctxt' = over _last (first addComma) $ map dropHsParTy ctxt+#if MIN_VERSION_ghc(9,4,0)+    return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]}+#else+    return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]}+#endif+  go (L _ HsForAllTy{hst_body}) = go hst_body+  go (L _ (HsParTy _ ty)) = go ty+  go ast@(L l _) = Rewrite (locA l) $ \df -> do+    -- there isn't a context, so we must create one+    constraint <- liftParseAST df constraintT+    lContext <- uniqueSrcSpanT+    lTop <- uniqueSrcSpanT+#if MIN_VERSION_ghc(9,4,0)+    let context = reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]+#else+    let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]+#endif+        annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]+        needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint+    ast <- pure $ setEntryDP ast (SameLine 1)++    return $ reLocA $ L lTop $ HsQualTy noExtField context ast++liftParseAST+    :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))+    => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)+liftParseAST df s = case parseAST df "" s of+  Right x ->  pure (makeDeltaAst x)+  Left _          -> TransformT $ lift $ Left $ "No parse: " <> s+++headMaybe :: [a] -> Maybe a+headMaybe []      = Nothing+headMaybe (a : _) = Just a++lastMaybe :: [a] -> Maybe a+lastMaybe []    = Nothing+lastMaybe other = Just $ last other++------------------------------------------------------------------------------+extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite+extendImport mparent identifier lDecl@(L l _) =+  Rewrite (locA l) $ \df -> do+    case mparent of+      -- This will also work for `ImportAllConstructors`+      -- Parsed source in GHC 9.4 uses absolute position annotation (RealSrcSpan),+      -- while rewriting relies on relative positions. ghc-exactprint has the utility+      -- makeDeltaAst for relativization.+      Just parent -> extendImportViaParent df parent identifier (makeDeltaAst lDecl)+      _           -> extendImportTopLevel identifier (makeDeltaAst lDecl)++-- | Add an identifier or a data type to import list. Expects a Delta AST+--+-- extendImportTopLevel "foo" AST:+--+-- import A --> Error+-- import A (foo) --> Error+-- import A (bar) --> import A (bar, foo)+extendImportTopLevel ::+  -- | rendered+  String ->+  LImportDecl GhcPs ->+  TransformT (Either String) (LImportDecl GhcPs)+extendImportTopLevel thing (L l it@ImportDecl{..})+#if MIN_VERSION_ghc(9,5,0)+  | Just (hide, L l' lies) <- ideclImportList+#else+  | Just (hide, L l' lies) <- ideclHiding+#endif+  = do+    src <- uniqueSrcSpanT+    top <- uniqueSrcSpanT+    let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing+    let alreadyImported =+          printOutputable (occName (unLoc rdr))+            `elem` map (printOutputable @OccName) (listify (const True) lies)+    when alreadyImported $+      TransformT $ lift (Left $ thing <> " already imported")++    let lie = reLocA $ L src $ IEName+#if MIN_VERSION_ghc(9,5,0)+                                noExtField+#endif+                                rdr+        x = reLocA $ L top $ IEVar+#if MIN_VERSION_ghc(9,8,0)+                               Nothing -- no deprecated+#else+                               noExtField+#endif+                               lie++    if x `elem` lies+      then TransformT $ lift (Left $ thing <> " already imported")+      else do+        let lies' = addCommaInImportList lies x+#if MIN_VERSION_ghc(9,5,0)+        return $ L l it{ideclImportList = Just (hide, L l' lies')}+#else+        return $ L l it{ideclHiding = Just (hide, L l' lies')}+#endif+extendImportTopLevel _ _ = TransformT $ lift $ Left "Unable to extend the import list"++wildCardSymbol :: String+wildCardSymbol = ".."++-- | Add an identifier with its parent to import list+--+-- extendImportViaParent "Bar" "Cons" AST:+--+-- import A --> Error+-- import A (Bar(..)) --> Error+-- import A (Bar(Cons)) --> Error+-- import A () --> import A (Bar(Cons))+-- import A (Foo, Bar) --> import A (Foo, Bar(Cons))+-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))+--+-- extendImportViaParent "Bar" ".." AST:+-- import A () --> import A (Bar(..))+-- import A (Foo, Bar) -> import A (Foo, Bar(..))+-- import A (Foo, Bar()) -> import A (Foo, Bar(..))+extendImportViaParent ::+  DynFlags ->+  -- | parent (already parenthesized if needs)+  String ->+  -- | rendered child+  String ->+  LImportDecl GhcPs ->+  TransformT (Either String) (LImportDecl GhcPs)+extendImportViaParent df parent child (L l it@ImportDecl{..})+#if MIN_VERSION_ghc(9,5,0)+  | Just (hide, L l' lies) <- ideclImportList = go hide l' [] lies+#else+  | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies+#endif+ where+  go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)+    | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports"+  go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)+    -- ThingAbs ie => ThingWith ie child+    | parent == unIEWrappedName ie = do+      srcChild <- uniqueSrcSpanT+      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child+          childLIE = reLocA $ L srcChild $ IEName+#if MIN_VERSION_ghc(9,5,0)+                                             noExtField+#endif+                                             childRdr+          x :: LIE GhcPs = L ll' $ IEThingWith+#if MIN_VERSION_ghc(9,7,0)+                                     (Nothing, addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments)+#else+                                     (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments)+#endif+                                     absIE NoIEWildcard [childLIE]++#if MIN_VERSION_ghc(9,5,0)+      return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)}+#else+      return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)}+#endif++  go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs)+    -- ThingWith ie lies' => ThingWith ie (lies' ++ [child])+    | parent == unIEWrappedName ie+    , child == wildCardSymbol = do+#if MIN_VERSION_ghc(9,5,0)+        let it' = it{ideclImportList = Just (hide, lies)}+#else+        let it' = it{ideclHiding = Just (hide, lies)}+#endif+            thing = IEThingWith newl twIE (IEWildcard 2) []+#if MIN_VERSION_ghc(9,7,0)+            newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l'''+#else+            newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l'''+#endif+            lies = L l' $ reverse pre ++ [L l'' thing] ++ xs+        return $ L l it'+    | parent == unIEWrappedName ie = do+        let hasSibling = not $ null lies'+        srcChild <- uniqueSrcSpanT+        let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child+        childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0+        let alreadyImported =+              printOutputable (occName (unLoc childRdr))+                `elem` map (printOutputable @OccName) (listify (const True) lies')+        when alreadyImported $+          TransformT $ lift (Left $ child <> " already included in " <> parent <> " imports")++        let childLIE = reLocA $ L srcChild $ IEName+#if MIN_VERSION_ghc(9,5,0)+                                               noExtField+#endif+                                               childRdr+#if MIN_VERSION_ghc(9,5,0)+        let it' = it{ideclImportList = Just (hide, lies)}+#else+        let it' = it{ideclHiding = Just (hide, lies)}+#endif+            lies = L l' $ reverse pre +++                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs+            fixLast = if hasSibling then first addComma else id+        return $ L l it'+  go hide l' pre (x : xs) = go hide l' (x : pre) xs+  go hide l' pre [] = do+      -- [] => ThingWith parent [child]+      l'' <- uniqueSrcSpanT+      srcParent <- uniqueSrcSpanT+      srcChild <- uniqueSrcSpanT+      parentRdr <- liftParseAST df parent+      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child+          isParentOperator = hasParen parent+      let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (epl 0) parentRdr'+                                               else IEName+#if MIN_VERSION_ghc(9,5,0)+                                                      noExtField+#endif+                                                      parentRdr'+          parentRdr' = modifyAnns parentRdr $ \case+              it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0}+              other -> other+          childLIE = reLocA $ L srcChild $ IEName+#if MIN_VERSION_ghc(9,5,0)+                                             noExtField+#endif+                                             childRdr+#if MIN_VERSION_ghc(9,7,0)+          listAnn = (Nothing, epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)])+#else+          listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]+#endif+          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]++          lies' = addCommaInImportList (reverse pre) x+#if MIN_VERSION_ghc(9,5,0)+      return $ L l it{ideclImportList = Just (hide, L l' lies')}+#else+      return $ L l it{ideclHiding = Just (hide, L l' lies')}+#endif+extendImportViaParent _ _ _ _ = TransformT $ lift $ Left "Unable to extend the import list via parent"++-- Add an item in an import list, taking care of adding comma if needed.+addCommaInImportList ::+  -- | Initial list+  [LocatedAn AnnListItem a]+  -- | Additional item+  -> LocatedAn AnnListItem a+  -> [LocatedAn AnnListItem a]+addCommaInImportList lies x =+    fixLast lies ++ [newItem]+  where+    isTrailingAnnComma :: TrailingAnn -> Bool+    isTrailingAnnComma (AddCommaAnn _) = True+    isTrailingAnnComma _ = False++    -- check if there is an existing trailing comma+    existingTrailingComma = fromMaybe False $ do+        L lastItemSrcAnn _ <- lastMaybe lies+        lastItemAnn <- case ann lastItemSrcAnn of+            EpAnn _ lastItemAnn _ -> pure lastItemAnn+            _ -> Nothing+        pure $ any isTrailingAnnComma (lann_trailing lastItemAnn)++    hasSibling = not $ null lies++    -- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the+    -- preceding item already has one.+    newItem = first (if existingTrailingComma then addComma else id) $+        setEntryDP x (SameLine $ if hasSibling then 1 else 0)++    -- Add the comma (if needed)+    fixLast :: [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a]+    fixLast = over _last (first (if existingTrailingComma then id else addComma))++#if MIN_VERSION_ghc(9,5,0)+unIEWrappedName :: IEWrappedName GhcPs -> String+#else+unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String+#endif+unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ)++hasParen :: String -> Bool+hasParen ('(' : _) = True+hasParen _         = False+++------------------------------------------------------------------------------++-- | Hide a symbol from import declaration+hideSymbol ::+  String -> LImportDecl GhcPs -> Rewrite+hideSymbol symbol lidecl@(L loc ImportDecl{..}) =+#if MIN_VERSION_ghc(9,5,0)+  case ideclImportList of+    Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing+    Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)+    Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports+#else+  case ideclHiding of+    Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing+    Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)+    Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports+#endif++extendHiding ::+  String ->+  LImportDecl GhcPs ->+  Maybe (XRec GhcPs [LIE GhcPs]) ->+  DynFlags ->+  TransformT (Either String) (LImportDecl GhcPs)+extendHiding symbol (L l idecls) mlies df = do+  L l' lies <- case mlies of+    Nothing -> do+        src <- uniqueSrcSpanT+        let ann = noAnnSrcSpanDP0 src+            ann' = flip (fmap.fmap) ann $ \x -> x+                {al_rest = [AddEpAnn AnnHiding (epl 1)]+                ,al_open = Just $ AddEpAnn AnnOpenP (epl 1)+                ,al_close = Just $ AddEpAnn AnnCloseP (epl 0)+                }+        return $ L ann' []+    Just pr -> pure pr+  let hasSibling = not $ null lies+  src <- uniqueSrcSpanT+  top <- uniqueSrcSpanT+  rdr <- liftParseAST df symbol+  rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr)+  let lie = reLocA $ L src $ IEName+#if MIN_VERSION_ghc(9,5,0)+                               noExtField+#endif+                               rdr+      x = reLocA $ L top $ IEVar+#if MIN_VERSION_ghc(9,7,0)+                             Nothing+#else+                             noExtField+#endif+                             lie+  x <- pure $ if hasSibling then first addComma x else x+  lies <- pure $ over _head (`setEntryDP` SameLine 1) lies+#if MIN_VERSION_ghc(9,5,0)+  return $ L l idecls{ideclImportList = Just (EverythingBut, L l' $ x : lies)}+#else+  return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)}+#endif+ where+  isOperator = not . all isAlphaNum . occNameString . rdrNameOcc++deleteFromImport ::+  String ->+  LImportDecl GhcPs ->+  XRec GhcPs [LIE GhcPs] ->+  DynFlags ->+  TransformT (Either String) (LImportDecl GhcPs)+deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do+  let edited = L lieLoc deletedLies+      lidecl' =+        L l $+          idecl+#if MIN_VERSION_ghc(9,5,0)+            { ideclImportList = Just (Exactly, edited)+#else+            { ideclHiding = Just (False, edited)+#endif+            }+  pure lidecl'+ where+  deletedLies =+    over _last removeTrailingComma $+    mapMaybe killLie lies+  killLie :: LIE GhcPs -> Maybe (LIE GhcPs)+  killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam))))+    | nam == symbol = Nothing+    | otherwise = Just v+  killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam))))+    | nam == symbol = Nothing+    | otherwise = Just v+  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons))+    | nam == symbol = Nothing+    | otherwise =+      Just $+        L lieL $+          IEThingWith+            xt+            ty+            wild+            (filter ((/= symbol) . unqualIEWrapName . unLoc) cons)+  killLie v = Just v
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs view
@@ -0,0 +1,141 @@+-- | Position indexed streams of characters+module Development.IDE.Plugin.CodeAction.PositionIndexed+  ( PositionIndexed+  , PositionIndexedString+  , indexedByPosition+  , indexedByPositionStartingFrom+  , extendAllToIncludeCommaIfPossible+  , extendToIncludePreviousNewlineIfPossible+  , mergeRanges+  )+where++import           Data.Char+import           Data.List+import           Language.LSP.Protocol.Types (Position (Position),+                                              Range (Range, _end, _start))++type PositionIndexed a = [(Position, a)]++type PositionIndexedString = PositionIndexed Char++-- | Add position indexing to a String.+--+--   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡+--   >   [ ((0,0),'h')+--   >   , ((0,1),'e')+--   >   , ((0,2),'y')+--   >   , ((0,3),'\n')+--   >   , ((1,0),' ')+--   >   , ((1,1),'h')+--   >   , ((1,2),'o')+--   >   ]+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where+  f (_, []) = Nothing+  f (p@(Position l _), '\n' : rest) =+    Just ((p, '\n'), (Position (l + 1) 0, rest))+  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))++-- | Add position indexing to a String.+--+--   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)+indexedByPosition :: String -> PositionIndexedString+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)++-- | Returns a tuple (before, contents, after) if the range is present.+--   The range is present only if both its start and end positions are present+unconsRange+  :: Range+  -> PositionIndexed a+  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)+unconsRange Range {..} indexedString+  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString+  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest+  = Just (before, mid, after)+  | otherwise+  = Nothing++-- | Strips out all the positions included in the range.+--   Returns 'Nothing' if the start or end of the range are not included in the input.+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)+stripRange r s = case unconsRange r s of+  Just (b, _, a) -> Just (b ++ a)+  Nothing        -> Nothing++-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.+--   Assumes input ranges are sorted on the start positions.+mergeRanges :: [Range] -> [Range]+mergeRanges (r : r' : rest)+  |+    -- r' is contained in r+    _end r > _end r'   = mergeRanges (r : rest)+  |+    -- r and r' are overlapping+    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)++  | otherwise          = r : mergeRanges (r' : rest)+mergeRanges other = other++-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas+--+-- @+--   a, |b|,  c  ===> a|, b|,  c+--   a,  b,  |c| ===> a,  b|,  c|+--   a, |b|, |c| ===> a|, b||, c|+-- @+--+-- If 'acceptNoComma' is enabled, additional ranges are returned+--+-- @+--   |a|       ===> |a|+--   |a|,  |b| ===> |a,|  |b|+-- @+extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range]+extendAllToIncludeCommaIfPossible acceptNoComma indexedString =+  mergeRanges . go indexedString . sortOn _start+ where+  go _ [] = []+  go input (r : rr)+    | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r+    , Just input' <- stripRange r' input+    = r' : go input' rr+    | otherwise+    = go input rr++extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range]+extendToIncludeCommaIfPossible acceptNoComma indexedString range+  | Just (before, _, after) <- unconsRange range indexedString+  , after' <- dropWhile (isSpace . snd) after+  , before' <- dropWhile (isSpace . snd) (reverse before)+  =+    -- a, |b|, c ===> a|, b|, c+    [ range { _start = start' } | (start', ',') : _ <- [before'] ]+    +++    -- a, |b|, c ===> a, |b, |c+    [ range { _end = end' }+    | (_, ',') : rest <- [after']+    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest+    ]+    +++    ([range | acceptNoComma])+  | otherwise+  = [range]++extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range+extendToIncludePreviousNewlineIfPossible indexedString range+  | Just (before, _, _) <- unconsRange range indexedString+  , maybeFirstSpacePos <- lastSpacePos $ reverse before+  = case maybeFirstSpacePos of+      Nothing  -> range+      Just pos -> range { _start = pos }+  | otherwise = range+  where+    lastSpacePos :: PositionIndexedString -> Maybe Position+    lastSpacePos [] = Nothing+    lastSpacePos ((pos, c):xs) =+      if not $ isSpace c+      then Nothing -- didn't find any space+      else case xs of+              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)+              _                        -> Just pos
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs view
@@ -0,0 +1,21 @@+module Development.IDE.Plugin.CodeAction.RuleTypes+    (PackageExports(..)+    ,IdentInfo(..)+    ) where++import           Control.DeepSeq                (NFData)+import           Data.Hashable                  (Hashable)+import           Data.Typeable                  (Typeable)+import           Development.IDE.Graph          (RuleResult)+import           Development.IDE.Types.Exports+import           Development.IDE.Types.HscEnvEq (HscEnvEq)+import           GHC.Generics                   (Generic)++-- Rule type for caching Package Exports+type instance RuleResult PackageExports = ExportsMap++newtype PackageExports = PackageExports HscEnvEq+    deriving (Eq, Show, Typeable, Generic)++instance Hashable PackageExports+instance NFData   PackageExports
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs view
@@ -0,0 +1,45 @@+module Development.IDE.Plugin.CodeAction.Util where++import           Data.Data                             (Data)+import           Data.Time.Clock.POSIX                 (POSIXTime,+                                                        getCurrentTime,+                                                        utcTimeToPOSIXSeconds)+import qualified Data.Unique                           as U+import           Debug.Trace+import           Development.IDE.GHC.Compat.ExactPrint as GHC+import           Development.IDE.GHC.Dump              (showAstDataHtml)+import           GHC.Stack+import           GHC.Utils.Outputable+import           System.Environment.Blank              (getEnvDefault)+import           System.IO.Unsafe+import           Text.Printf+--------------------------------------------------------------------------------+-- Tracing exactprint terms++-- Should in `Development.IDE.GHC.Orphans`,+-- leave it here to prevent cyclic module dependency++{-# NOINLINE timestamp #-}+timestamp :: POSIXTime+timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime++debugAST :: Bool+debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1"++-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection+traceAst :: (Data a, ExactPrint a, HasCallStack) => String -> a -> a+traceAst lbl x+  | debugAST = trace doTrace x+  | otherwise = x+  where+    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}+    htmlDump = showAstDataHtml x+    doTrace = unsafePerformIO $ do+        u <- U.newUnique+        let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)+        writeFile htmlDumpFileName $ renderDump htmlDump+        return $ unlines+            [prettyCallStack callStack ++ ":"+            , exactPrint x+            , "file://" ++ htmlDumpFileName]+
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Plugin.Plugins.AddArgument (plugin) where++import           Control.Monad                             (join)+import           Control.Monad.Trans.Class                 (lift)+import           Data.Bifunctor                            (Bifunctor (..))+import           Data.Either.Extra                         (maybeToEither)+import qualified Data.Text                                 as T+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.ExactPrint     (exactPrint,+                                                            makeDeltaAst)+import           Development.IDE.GHC.Error                 (spanContainsRange)+import           Development.IDE.GHC.ExactPrint            (genAnchor1,+                                                            modifyMgMatchesT',+                                                            modifySigWithM,+                                                            modifySmallestDeclWithM)+import           Development.IDE.Plugin.Plugins.Diagnostic+import           GHC                                       (EpAnn (..),+                                                            SrcSpanAnn' (SrcSpanAnn),+                                                            SrcSpanAnnA,+                                                            SrcSpanAnnN,+                                                            emptyComments,+                                                            noAnn)+import           GHC.Types.SrcLoc                          (generatedSrcSpan)+import           Ide.Plugin.Error                          (PluginError (PluginInternalError))+import           Ide.PluginUtils                           (makeDiffTextEdit)+import           Language.Haskell.GHC.ExactPrint           (TransformT (..),+                                                            noAnnSrcSpanDP1,+                                                            runTransformT)+import           Language.LSP.Protocol.Types++#if !MIN_VERSION_ghc(9,4,0)+import           GHC                                       (TrailingAnn (..))+import           GHC.Hs                                    (IsUnicodeSyntax (..))+import           Language.Haskell.GHC.ExactPrint.Transform (d1)+#endif++#if MIN_VERSION_ghc(9,4,0)+import           Development.IDE.GHC.ExactPrint            (epl)+import           GHC.Parser.Annotation                     (TokenLocation (..))+#endif++-- When GHC tells us that a variable is not bound, it will tell us either:+--  - there is an unbound variable with a given type+--  - there is an unbound variable (GHC provides no type suggestion)+--+-- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the+-- last position of each LHS of the top-level bindings for this HsDecl).+--+-- NOTE When adding a new argument to a declaration, the corresponding argument's type in declaration's signature might+--      not be the last type in the signature, such as:+--         foo :: a -> b -> c -> d+--         foo a b = \c -> ...+--      In this case a new argument would have to add its type between b and c in the signature.+plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])]+plugin parsedModule Diagnostic {_message, _range}+  | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ+  | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ)+  | otherwise = pure []+  where+    message = unifySpaces _message++-- Given a name for the new binding, add a new pattern to the match in the last position,+-- returning how many patterns there were in this match prior to the transformation:+--      addArgToMatch "foo" `bar arg1 arg2 = ...`+--   => (`bar arg1 arg2 foo = ...`, 2)+addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int)+addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) =+  let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name+      newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName)+  in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), Prelude.length pats)++-- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind.+-- Also return:+--   - the declaration's name+--   - the number of bound patterns in the declaration's matches prior to the transformation+--+-- For example:+--    insertArg "new_pat" `foo bar baz = 1`+-- => (`foo bar baz new_pat = 1`, Just ("foo", 2))+appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int))+appendFinalPatToMatches name = \case+  (L locDecl (ValD xVal fun@FunBind{fun_matches=mg,fun_id = idFunBind})) -> do+    (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats+    numPats <- TransformT $ lift $ maybeToEither (PluginInternalError "Unexpected empty match group in HsDecl") numPatsMay+    let decl' = L locDecl (ValD xVal fun{fun_matches=mg'})+    pure (decl', Just (idFunBind, numPats))+  decl -> pure (decl, Nothing)+  where+    combineMatchNumPats  Nothing other = pure other+    combineMatchNumPats  other Nothing = pure other+    combineMatchNumPats  (Just l) (Just r)+      | l == r = pure (Just l)+      | otherwise = Left $ PluginInternalError "Unexpected different numbers of patterns in HsDecl MatchGroup"++-- The add argument works as follows:+--  1. Attempt to add the given name as the last pattern of the declaration that contains `range`.+--  2. If such a declaration exists, use that declaration's name to modify the signature of said declaration, if it+--     has a type signature.+--+-- NOTE For the following situation, the type signature is not updated (it's unclear what should happen):+--   type FunctionTySyn = () -> Int+--   foo :: FunctionTySyn+--   foo () = new_def+--+-- TODO instead of inserting a typed hole; use GHC's suggested type from the error+addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])]+addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do+    (newSource, _, _) <- runTransformT $ do+      (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc)+      case matchedDeclNameMay of+          Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'+          Nothing -> pure moduleSrc'+    let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource)+    pure [("Add argument ‘" <> name <> "’ to function", diff)]+  where+    addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg+    addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name++    spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range)++-- Transform an LHsType into a list of arguments and return type, to make transformations easier.+hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs)+hsTypeToFunTypeAsList = \case+  L spanAnnA (HsFunTy xFunTy arrow lhs rhs) ->+    let (rhsArgs, rhsRes) = hsTypeToFunTypeAsList rhs+    in ((spanAnnA, xFunTy, arrow, lhs):rhsArgs, rhsRes)+  ty -> ([], ty)++-- The inverse of `hsTypeToFunTypeAsList`+hsTypeFromFunTypeAsList :: ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) -> LHsType GhcPs+hsTypeFromFunTypeAsList (args, res) =+  foldr (\(spanAnnA, xFunTy, arrow, argTy) res -> L spanAnnA $ HsFunTy xFunTy arrow argTy res) res args++-- Add a typed hole to a type signature in the given argument position:+--   0 `foo :: ()` => foo :: _ -> ()+--   2 `foo :: FunctionTySyn` => foo :: FunctionTySyn+--   1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int+addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs)+addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =+    let (args, res) = hsTypeToFunTypeAsList lsigTy+#if MIN_VERSION_ghc(9,4,0)+        wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem []) emptyComments) generatedSrcSpan+        arrowAnn = TokenLoc (epl 1)+        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow (L arrowAnn HsNormalTok), L wildCardAnn $ HsWildCardTy noExtField)+#else+        wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan+        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField)+#endif+        -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments+        --      in the signature, then we return the original type signature.+        --      This situation most likely occurs due to a function type synonym in the signature+        insertArg n _ | n < 0 = error "Not possible"+        insertArg 0 as = newArg:as+        insertArg _ [] = []+        insertArg n (a:as) = a : insertArg (n - 1) as+        lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)+    in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')+
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs view
@@ -0,0 +1,56 @@+module Development.IDE.Plugin.Plugins.Diagnostic (+  matchVariableNotInScope,+  matchRegexUnifySpaces,+  unifySpaces,+  matchFoundHole,+  matchFoundHoleIncludeUnderscore,+  )+  where++import           Data.Bifunctor  (Bifunctor (..))+import qualified Data.Text       as T+import           Text.Regex.TDFA ((=~~))++unifySpaces :: T.Text -> T.Text+unifySpaces    = T.unwords . T.words++-- | Returns Just (the submatches) for the first capture, or Nothing.+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]+matchRegex message regex = case message =~~ regex of+    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings+    Nothing                                                -> Nothing++-- | 'matchRegex' combined with 'unifySpaces'+matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]+matchRegexUnifySpaces message = matchRegex (unifySpaces message)++matchFoundHole :: T.Text -> Maybe (T.Text, T.Text)+matchFoundHole message+  | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" =+      Just (name, typ)+  | otherwise = Nothing++matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text)+matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message++matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)+matchVariableNotInScope message+  --     * Variable not in scope:+  --         suggestAcion :: Maybe T.Text -> Range -> Range+  --     * Variable not in scope:+  --         suggestAcion+  | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ)+  | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing)+  | otherwise = Nothing+  where+    matchVariableNotInScopeTyped message+      | Just [name, typ0] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"+      , -- When some name in scope is similar to not-in-scope variable, the type is followed by+        -- "Suggested fix: Perhaps use ..."+        typ:_ <- T.splitOn " Suggested fix:" typ0 =+          Just (name, typ)+      | otherwise = Nothing+    matchVariableNotInScopeUntyped message+      | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" =+          Just name+      | otherwise = Nothing
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs view
@@ -0,0 +1,104 @@+module Development.IDE.Plugin.Plugins.FillHole+  ( suggestFillHole+  ) where++import           Control.Monad                             (guard)+import           Data.Char+import qualified Data.Text                                 as T+import           Development.IDE.Plugin.Plugins.Diagnostic+import           Language.LSP.Protocol.Types               (Diagnostic (..),+                                                            TextEdit (TextEdit))+import           Text.Regex.TDFA                           (MatchResult (..),+                                                            (=~))++suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]+suggestFillHole Diagnostic{_range=_range,..}+    | Just holeName <- extractHoleName _message+    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =+      let isInfixHole = _message =~ addBackticks holeName :: Bool in+        map (proposeHoleFit holeName False isInfixHole) holeFits+        ++ map (proposeHoleFit holeName True isInfixHole) refFits+    | otherwise = []+    where+      extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"+      addBackticks text = "`" <> text <> "`"+      addParens text = "(" <> text <> ")"+      proposeHoleFit holeName parenthise isInfixHole name =+        case T.uncons name of+          Nothing -> error "impossible: empty name provided by ghc"+          Just (firstChr, _) ->+            let isInfixOperator = firstChr == '('+                name' = getOperatorNotation isInfixHole isInfixOperator name in+              ( "replace " <> holeName <> " with " <> name+              , TextEdit _range (if parenthise then addParens name' else name')+              )+      getOperatorNotation True False name                    = addBackticks name+      getOperatorNotation True True name                     = T.drop 1 (T.dropEnd 1 name)+      getOperatorNotation _isInfixHole _isInfixOperator name = name+      headOrThrow msg = \case+        [] -> error msg+        (x:_) -> x++processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])+processHoleSuggestions mm = (holeSuggestions, refSuggestions)+{-+    • Found hole: _ :: LSP.Handlers++      Valid hole fits include def+      Valid refinement hole fits include+        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)+        fromJust (_ :: Maybe LSP.Handlers)+        haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams+                                                                                                        LSP.Handlers)+        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                (_ :: LSP.Handlers)+                (_ :: T.Text)+        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                 (_ :: LSP.Handlers)+                 (_ :: T.Text)+-}+  where+    t = id @T.Text+    holeSuggestions = do+      -- get the text indented under Valid hole fits+      validHolesSection <-+        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm+      -- the Valid hole fits line can contain a hole fit+      holeFitLine <-+        mapHead+            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))+            validHolesSection+      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine+      guard (not $ T.null holeFit)+      return holeFit+    refSuggestions = do -- @[]+      -- get the text indented under Valid refinement hole fits+      refinementSection <-+        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm+      case refinementSection of+        [] -> error "GHC provided invalid hole fit options"+        (_:refinementSection) -> do+          -- get the text for each hole fit+          holeFitLines <- getIndentedGroups refinementSection+          let holeFit = T.strip $ T.unwords holeFitLines+          guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"+          return holeFit++    mapHead f (a:aa) = f a : aa+    mapHead _ []     = []++-- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroups :: [T.Text] -> [[T.Text]]+getIndentedGroups [] = []+getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll+-- |+-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]+getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of+    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of+        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest+    _ -> []++indentation :: T.Text -> Int+indentation = T.length . T.takeWhile isSpace+
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs view
@@ -0,0 +1,79 @@+module Development.IDE.Plugin.Plugins.FillTypeWildcard+  ( suggestFillTypeWildcard+  ) where++import           Data.Char+import qualified Data.Text                   as T+import           Language.LSP.Protocol.Types (Diagnostic (..),+                                              TextEdit (TextEdit))++suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]+suggestFillTypeWildcard Diagnostic{_range=_range,..}+-- Foo.hs:3:8: error:+--     * Found type wildcard `_' standing for `p -> p1 -> p'+    | "Found type wildcard" `T.isInfixOf` _message+    , " standing for " `T.isInfixOf` _message+    , typeSignature <- extractWildCardTypeSignature _message+        =  [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]+    | otherwise = []++-- | Extract the type and surround it in parentheses except in obviously safe cases.+--+-- Inferring when parentheses are actually needed around the type signature would+-- require understanding both the precedence of the context of the hole and of+-- the signature itself. Inserting them (almost) unconditionally is ugly but safe.+extractWildCardTypeSignature :: T.Text -> T.Text+extractWildCardTypeSignature msg+  | enclosed || not isApp || isToplevelSig = sig+  | otherwise                              = "(" <> sig <> ")"+  where+    msgSigPart      = snd $ T.breakOnEnd "standing for " msg+    (sig, rest)     = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart+    -- If we're completing something like ‘foo :: _’ parens can be safely omitted.+    isToplevelSig   = errorMessageRefersToToplevelHole rest+    -- Parenthesize type applications, e.g. (Maybe Char).+    isApp           = T.any isSpace sig+    -- Do not add extra parentheses to lists, tuples and already parenthesized types.+    enclosed        =+      case T.uncons sig of+        Nothing -> error "GHC provided invalid type"+        Just (firstChr, _) -> not (T.null sig) && (firstChr, T.last sig) `elem` [('(', ')'), ('[', ']')]++-- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@.+-- The former is considered toplevel case for which the function returns 'True',+-- the latter is not toplevel and the returned value is 'False'.+--+-- When type hole is at toplevel then there’s a line starting with+-- "• In the type signature" which ends with " :: _" like in the+-- following snippet:+--+-- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error:+--     • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’+--       To use the inferred type, enable PartialTypeSignatures+--     • In the type signature: decl :: _+--       In an equation for ‘splitAnnots’:+--           splitAnnots m@HsModule {hsmodAnn, hsmodDecls}+--             = undefined+--             where+--                 ann :: SrcSpanAnnA+--                 decl :: _+--                 L ann decl = head hsmodDecls+--     • Relevant bindings include+--       [REDACTED]+--+-- When type hole is not at toplevel there’s a stack of where+-- the hole was located ending with "In the type signature":+--+-- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error:+--     • Found type wildcard ‘_’ standing for ‘GhcPs’+--       To use the inferred type, enable PartialTypeSignatures+--     • In the first argument of ‘HsDecl’, namely ‘_’+--       In the type ‘HsDecl _’+--       In the type signature: decl :: HsDecl _+--     • Relevant bindings include+--       [REDACTED]+errorMessageRefersToToplevelHole :: T.Text -> Bool+errorMessageRefersToToplevelHole msg =+  not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest+  where+    (prefix, rest) = T.breakOn "• In the type signature:" msg
+ plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs view
@@ -0,0 +1,98 @@+module Development.IDE.Plugin.Plugins.ImportUtils+  ( ImportStyle(..),+    quickFixImportKind',+    quickFixImportKind,+    renderImportStyle,+    unImportStyle,+    importStyles,+    QualifiedImportStyle(..),+    qualifiedImportStyle+  ) where++import           Data.List.NonEmpty                           (NonEmpty ((:|)))+import qualified Data.Text                                    as T+import           Development.IDE.GHC.Compat+import           Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol)+import           Development.IDE.Types.Exports+import           Language.LSP.Protocol.Types                  (CodeActionKind (..))++-- | Possible import styles for an 'IdentInfo'.+--+-- The first 'Text' parameter corresponds to the 'rendered' field of the+-- 'IdentInfo'.+data ImportStyle+    = ImportTopLevel T.Text+      -- ^ Import a top-level export from a module, e.g., a function, a type, a+      -- class.+      --+      -- > import M (?)+      --+      -- Some exports that have a parent, like a type-class method or an+      -- associated type/data family, can still be imported as a top-level+      -- import.+      --+      -- Note that this is not the case for constructors, they must always be+      -- imported as part of their parent data type.++    | ImportViaParent T.Text T.Text+      -- ^ Import an export (first parameter) through its parent (second+      -- parameter).+      --+      -- import M (P(?))+      --+      -- @P@ and @?@ can be a data type and a constructor, a class and a method,+      -- a class and an associated type/data family, etc.++    | ImportAllConstructors T.Text+      -- ^ Import all constructors for a specific data type.+      --+      -- import M (P(..))+      --+      -- @P@ can be a data type or a class.+  deriving Show++importStyles :: IdentInfo -> NonEmpty ImportStyle+importStyles i@(IdentInfo {parent})+  | Just p <- pr+    -- Constructors always have to be imported via their parent data type, but+    -- methods and associated type/data families can also be imported as+    -- top-level exports.+  = ImportViaParent rend p+      :| [ImportTopLevel rend | not (isDatacon i)]+      <> [ImportAllConstructors p]+  | otherwise+  = ImportTopLevel rend :| []+  where rend = rendered i+        pr = occNameText <$> parent++-- | Used for adding new imports+renderImportStyle :: ImportStyle -> T.Text+renderImportStyle (ImportTopLevel x)   = x+renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"+renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"+renderImportStyle (ImportAllConstructors p) = p <> "(..)"++-- | Used for extending import lists+unImportStyle :: ImportStyle -> (Maybe String, String)+unImportStyle (ImportTopLevel x)        = (Nothing, T.unpack x)+unImportStyle (ImportViaParent x y)     = (Just $ T.unpack y, T.unpack x)+unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)+++quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind+quickFixImportKind' x (ImportTopLevel _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.topLevel"+quickFixImportKind' x (ImportViaParent _ _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.withParent"+quickFixImportKind' x (ImportAllConstructors _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.allConstructors"++quickFixImportKind :: T.Text -> CodeActionKind+quickFixImportKind x = CodeActionKind_Custom $ "quickfix.import." <> x++-- | Possible import styles for qualified imports+data QualifiedImportStyle = QualifiedImportPostfix | QualifiedImportPrefix+    deriving Show++qualifiedImportStyle :: DynFlags -> QualifiedImportStyle+qualifiedImportStyle df | hasImportQualifedPostEnabled && hasPrePositiveQualifiedWarning = QualifiedImportPostfix+                        | otherwise = QualifiedImportPrefix+  where hasImportQualifedPostEnabled = xopt ImportQualifiedPost df+        hasPrePositiveQualifiedWarning = wopt Opt_WarnPrepositiveQualifiedModule df
+ plugins/hls-refactor-plugin/test/Main.hs view
@@ -0,0 +1,3755 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeOperators         #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- don't warn about usage HasCallStack++module Main+  ( main+  ) where++import           Control.Applicative.Combinators+import           Control.Lens                             ((^.))+import           Control.Monad+import           Data.Default+import           Data.Foldable+import           Data.List.Extra+import           Data.Maybe+import qualified Data.Text                                as T+import           Data.Tuple.Extra+import           Development.IDE.GHC.Util+import           Development.IDE.Plugin.Completions.Types (extendImportCommandId)+import           Development.IDE.Test+import           Development.IDE.Types.Location+import           Development.Shake                        (getDirectoryFilesIO)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types              hiding+                                                          (SemanticTokensEdit (_start),+                                                           mkRange)+import           Language.LSP.Test+import           System.Directory+import           System.FilePath+import qualified System.IO.Extra+import           System.IO.Extra                          hiding (withTempDir)+import           System.Time.Extra+import           Test.Tasty+import           Test.Tasty.ExpectedFailure+import           Test.Tasty.HUnit+import           Text.Regex.TDFA                          ((=~))+++import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports)+import           Test.Hls++import qualified Development.IDE.Plugin.CodeAction        as Refactor+import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde+import qualified Test.AddArgument++main :: IO ()+main = defaultTestRunner tests++refactorPlugin :: IO (IdePlugins IdeState)+refactorPlugin = do+  exactprintLog <- pluginTestRecorder+  ghcideLog <- pluginTestRecorder+  pure $ IdePlugins $+      [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports"+      , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures"+      , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings"+      , Refactor.fillHolePluginDescriptor exactprintLog "ghcide-code-actions-fill-holes"+      , Refactor.extendImportPluginDescriptor exactprintLog "ghcide-completions-1"+      ] ++ GhcIde.descriptors ghcideLog++tests :: TestTree+tests =+  testGroup "refactor"+  [ initializeTests+  , codeActionTests+  , codeActionHelperFunctionTests+  , completionTests+  ]++initializeTests :: TestTree+initializeTests = withResource acquire release tests+  where+    tests :: IO (TResponseMessage Method_Initialize) -> TestTree+    tests getInitializeResponse = testGroup "initialize response capabilities"+        [ chk "   code action"             _codeActionProvider  (Just (InR (CodeActionOptions {_workDoneProgress = Just False, _codeActionKinds = Nothing, _resolveProvider = Just False})))+        , che "   execute command"         _executeCommandProvider [extendImportCommandId]+        ]+      where+        chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree+        chk title getActual expected =+          testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir++        che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree+        che title getActual expected = testCase title $ do+          ir <- getInitializeResponse+          ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of+            Just eco -> pure eco+            Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing"+          -- Check if expected exists in commands. Note that commands can arrive in different order.+          mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected++    acquire :: IO (TResponseMessage Method_Initialize)+    acquire = run initializeResponse++    release :: TResponseMessage Method_Initialize -> IO ()+    release = mempty++    innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities+    innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c+    innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"+++completionTests :: TestTree+completionTests =+    testGroup "auto import snippets"+      [ completionCommandTest+        "show imports not in list - simple"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (msum)", "f = joi"]+        (Position 3 6)+        "join"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (msum, join)", "f = joi"]+      , completionCommandTest+        "show imports not in list - multi-line"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (\n    msum)", "f = joi"]+        (Position 4 6)+        "join"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (\n    msum, join)", "f = joi"]+      , completionCommandTest+        "show imports not in list - names with _"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"]+        (Position 3 11)+        "mapM_"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"]+      , completionCommandTest+        "show imports not in list - initial empty list"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad as M ()", "f = M.joi"]+        (Position 3 10)+        "join"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad as M (join)", "f = M.joi"]+      , testGroup "qualified imports"+        [ completionCommandTest+            "single"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad ()", "f = Control.Monad.joi"]+            (Position 3 22)+            "join"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"]+        , completionCommandTest+            "as"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad as M ()", "f = M.joi"]+            (Position 3 10)+            "join"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad as M (join)", "f = M.joi"]+        , completionCommandTest+            "multiple"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"]+            (Position 4 10)+            "join"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"]+        -- Regression test for https://github.com/haskell/haskell-language-server/issues/2824+        , completionNoCommandTest+            "explicit qualified"+            ["{-# LANGUAGE NoImplicitPrelude #-}",+            "module A where", "import qualified Control.Monad as M (j)"]+            (Position 2 38)+            "join"+        , completionNoCommandTest+            "explicit qualified post"+            ["{-# LANGUAGE NoImplicitPrelude, ImportQualifiedPost #-}",+            "module A where", "import Control.Monad qualified as M (j)"]+            (Position 2 38)+            "join"+        , completionNoCommandTest+            "multiline import"+            [ "{-# LANGUAGE NoImplicitPrelude #-}"+            , "module A where", "import Control.Monad", "    (fore)"]+            (Position 3 9)+            "forever"+        ]+      , testGroup "Data constructor"+        [ completionCommandTest+            "not imported"+            ["module A where", "import Text.Printf ()", "ZeroPad"]+            (Position 2 4)+            "ZeroPad"+            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]+        , completionCommandTest+            "parent imported abs"+            ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"]+            (Position 2 4)+            "ZeroPad"+            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]+        , completionNoCommandTest+            "parent imported all"+            ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"]+            (Position 2 4)+            "ZeroPad"+        , completionNoCommandTest+            "already imported"+            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]+            (Position 2 4)+            "ZeroPad"+        , completionNoCommandTest+            "function from Prelude"+            ["module A where", "import Data.Maybe ()", "Nothing"]+            (Position 2 4)+            "Nothing"+        , completionCommandTest+            "type operator parent"+            ["module A where", "import Data.Type.Equality ()", "f = Ref"]+            (Position 2 8)+            "Refl"+            ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"]+        ]+      , testGroup "Record completion"+        [ completionCommandTest+            "not imported"+            ["module A where", "import Text.Printf ()", "FormatParse"]+            (Position 2 10)+            "FormatParse"+            ["module A where", "import Text.Printf (FormatParse)", "FormatParse"]+        , completionCommandTest+            "parent imported"+            ["module A where", "import Text.Printf (FormatParse)", "FormatParse"]+            (Position 2 10)+            "FormatParse"+            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]+        , completionNoCommandTest+            "already imported"+            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]+            (Position 2 10)+            "FormatParse"+        ]+        , testGroup "Package completion"+          [ completionCommandTest+                  "import Data.Sequence"+                  ["module A where", "foo :: Seq"]+                  (Position 1 9)+                  "Seq"+                  ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"]++          , completionCommandTest+                  "qualified import"+                  ["module A where", "foo :: Seq.Seq"]+                  (Position 1 13)+                  "Seq"+                  ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"]+          ]+      ]++completionCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> [T.Text] -> TestTree+completionCommandTest name src pos wanted expected = testSession name $ do+  docId <- createDoc "A.hs" "haskell" (T.unlines src)+  _ <- waitForDiagnostics+  compls <- skipManyTill anyMessage (getCompletions docId pos)+  let wantedC = mapMaybe (\case+        CompletionItem {_insertText = Just x, _command = Just cmd}+          | wanted `T.isPrefixOf` x -> Just cmd+        _                           -> Nothing+        ) compls+  case wantedC of+    [] ->+      liftIO $ assertFailure $ "Cannot find completion " <> show wanted <> " in: " <> show [_label | CompletionItem {_label} <- compls]+    command:_ -> do+      executeCommand command+      if src /= expected+        then do+          modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId)+          liftIO $ modifiedCode @?= T.unlines expected+        else do+          expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit ->+            liftIO $ assertFailure $ "Expected no edit but got: " <> show edit++completionNoCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> TestTree+completionNoCommandTest name src pos wanted = testSession name $ do+  docId <- createDoc "A.hs" "haskell" (T.unlines src)+  _ <- waitForDiagnostics+  compls <- getCompletions docId pos+  let isPrefixOfInsertOrLabel ci = any (wanted `T.isPrefixOf`) [fromMaybe "" (ci ^. L.insertText), ci ^. L.label]+  case find isPrefixOfInsertOrLabel compls of+    Nothing ->+      liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]+    Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command+++codeActionTests :: TestTree+codeActionTests = testGroup "code actions"+  [ suggestImportDisambiguationTests+  , insertImportTests+  , extendImportTests+  , renameActionTests+  , typeWildCardActionTests+  , removeImportTests+  , suggestImportClassMethodTests+  , suggestImportTests+  , suggestAddRecordFieldImportTests+  , suggestHideShadowTests+  , fixConstructorImportTests+  , fixModuleImportTypoTests+  , importRenameActionTests+  , fillTypedHoleTests+  , addSigActionTests+  , insertNewDefinitionTests+  , deleteUnusedDefinitionTests+  , addInstanceConstraintTests+  , addFunctionConstraintTests+  , removeRedundantConstraintsTests+  , addTypeAnnotationsToLiteralsTest+  , exportUnusedTests+  , addImplicitParamsConstraintTests+  , removeExportTests+  , Test.AddArgument.tests+  ]++insertImportTests :: TestTree+insertImportTests = testGroup "insert import"+  [ checkImport+        "module where keyword lower in file no exports"+        "WhereKeywordLowerInFileNoExports.hs"+        "WhereKeywordLowerInFileNoExports.expected.hs"+        "import Data.Int"+  , checkImport+        "module where keyword lower in file with exports"+        "WhereDeclLowerInFile.hs"+        "WhereDeclLowerInFile.expected.hs"+        "import Data.Int"+  , checkImport+        "module where keyword lower in file with comments before it"+        "WhereDeclLowerInFileWithCommentsBeforeIt.hs"+        "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs"+        "import Data.Int"+  , expectFailBecause+      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"+      (checkImport+         "Shebang not at top with spaces"+         "ShebangNotAtTopWithSpaces.hs"+         "ShebangNotAtTopWithSpaces.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"+      (checkImport+         "Shebang not at top no space"+         "ShebangNotAtTopNoSpace.hs"+         "ShebangNotAtTopNoSpace.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      ("'findNextPragmaPosition' function doesn't account for case "+      ++ "when OPTIONS_GHC pragma is not placed at top of file")+      (checkImport+         "OPTIONS_GHC pragma not at top with spaces"+         "OptionsNotAtTopWithSpaces.hs"+         "OptionsNotAtTopWithSpaces.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      ("'findNextPragmaPosition' function doesn't account for "+      ++ "case when shebang is not placed at top of file")+      (checkImport+         "Shebang not at top of file"+         "ShebangNotAtTop.hs"+         "ShebangNotAtTop.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      ("'findNextPragmaPosition' function doesn't account for case "+      ++ "when OPTIONS_GHC is not placed at top of file")+      (checkImport+         "OPTIONS_GHC pragma not at top of file"+         "OptionsPragmaNotAtTop.hs"+         "OptionsPragmaNotAtTop.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      ("'findNextPragmaPosition' function doesn't account for case when "+      ++ "OPTIONS_GHC pragma is not placed at top of file")+      (checkImport+         "pragma not at top with comment at top"+         "PragmaNotAtTopWithCommentsAtTop.hs"+         "PragmaNotAtTopWithCommentsAtTop.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      ("'findNextPragmaPosition' function doesn't account for case when "+      ++ "OPTIONS_GHC pragma is not placed at top of file")+      (checkImport+         "pragma not at top multiple comments"+         "PragmaNotAtTopMultipleComments.hs"+         "PragmaNotAtTopMultipleComments.expected.hs"+         "import Data.Monoid")+  , expectFailBecause+      "'findNextPragmaPosition' function doesn't account for case of multiline pragmas"+      (checkImport+         "after multiline language pragmas"+         "MultiLinePragma.hs"+         "MultiLinePragma.expected.hs"+         "import Data.Monoid")+  , checkImport+      "pragmas not at top with module declaration"+      "PragmaNotAtTopWithModuleDecl.hs"+      "PragmaNotAtTopWithModuleDecl.expected.hs"+      "import Data.Monoid"+  , checkImport+      "pragmas not at top with imports"+      "PragmaNotAtTopWithImports.hs"+      "PragmaNotAtTopWithImports.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above comment at top of module"+      "CommentAtTop.hs"+      "CommentAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above multiple comments below"+      "CommentAtTopMultipleComments.hs"+      "CommentAtTopMultipleComments.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above curly brace comment"+      "CommentCurlyBraceAtTop.hs"+      "CommentCurlyBraceAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above multi-line comment"+      "MultiLineCommentAtTop.hs"+      "MultiLineCommentAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above comment with no module explicit exports"+      "NoExplicitExportCommentAtTop.hs"+      "NoExplicitExportCommentAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above two-dash comment with no pipe"+      "TwoDashOnlyComment.hs"+      "TwoDashOnlyComment.expected.hs"+      "import Data.Monoid"+  , checkImport+      "above comment with no (module .. where) decl"+      "NoModuleDeclarationCommentAtTop.hs"+      "NoModuleDeclarationCommentAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "comment not at top with no (module .. where) decl"+      "NoModuleDeclaration.hs"+      "NoModuleDeclaration.expected.hs"+      "import Data.Monoid"+  , checkImport+      "comment not at top (data dec is)"+      "DataAtTop.hs"+      "DataAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "comment not at top (newtype is)"+      "NewTypeAtTop.hs"+      "NewTypeAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with no explicit module exports"+      "NoExplicitExports.hs"+      "NoExplicitExports.expected.hs"+      "import Data.Monoid"+  , checkImport+      "add to correctly placed existing import"+      "ImportAtTop.hs"+      "ImportAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "add to multiple correctly placed existing imports"+      "MultipleImportsAtTop.hs"+      "MultipleImportsAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with language pragma at top of module"+      "LangPragmaModuleAtTop.hs"+      "LangPragmaModuleAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with language pragma and explicit module exports"+      "LangPragmaModuleWithComment.hs"+      "LangPragmaModuleWithComment.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with language pragma at top and no module declaration"+      "LanguagePragmaAtTop.hs"+      "LanguagePragmaAtTop.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with multiple lang pragmas and no module declaration"+      "MultipleLanguagePragmasNoModuleDeclaration.hs"+      "MultipleLanguagePragmasNoModuleDeclaration.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with pragmas and shebangs"+      "LanguagePragmasThenShebangs.hs"+      "LanguagePragmasThenShebangs.expected.hs"+      "import Data.Monoid"+  , checkImport+      "with pragmas and shebangs but no comment at top"+      "PragmasAndShebangsNoComment.hs"+      "PragmasAndShebangsNoComment.expected.hs"+      "import Data.Monoid"+  , checkImport+      "module decl no exports under pragmas and shebangs"+      "PragmasShebangsAndModuleDecl.hs"+      "PragmasShebangsAndModuleDecl.expected.hs"+      "import Data.Monoid"+  , checkImport+      "module decl with explicit import under pragmas and shebangs"+      "PragmasShebangsModuleExplicitExports.hs"+      "PragmasShebangsModuleExplicitExports.expected.hs"+      "import Data.Monoid"+  , checkImport+      "module decl and multiple imports"+      "ModuleDeclAndImports.hs"+      "ModuleDeclAndImports.expected.hs"+      "import Data.Monoid"+  , importQualifiedTests+  ]++importQualifiedTests :: TestTree+importQualifiedTests = testGroup "import qualified prefix suggestions"+  [ checkImport'+      "qualified import works with 3.8 code action kinds"+      "ImportQualified.hs"+      "ImportQualified.expected.hs"+      "import qualified Control.Monad as Control"+      ["import Control.Monad (when)"]+  , checkImport'+      "qualified import in postfix position works with 3.8 code action kinds"+      "ImportPostQualified.hs"+      "ImportPostQualified.expected.hs"+      "import Control.Monad qualified as Control"+      ["import qualified Control.Monad as Control", "import Control.Monad (when)"]+  ]++checkImport :: TestName -> FilePath -> FilePath -> T.Text -> TestTree+checkImport testName originalPath expectedPath action =+  checkImport' testName originalPath expectedPath action []++checkImport' :: TestName -> FilePath -> FilePath -> T.Text -> [T.Text] -> TestTree+checkImport' testName originalPath expectedPath action excludedActions =+  testSessionWithExtraFiles "import-placement" testName $ \dir ->+    check (dir </> originalPath) (dir </> expectedPath) action+  where+    check :: FilePath -> FilePath -> T.Text -> Session ()+    check originalPath expectedPath action = do+      oSrc <- liftIO $ readFileUtf8 originalPath+      shouldBeDocContents <- liftIO $ readFileUtf8 expectedPath+      originalDoc <- createDoc originalPath "haskell" oSrc+      _ <- waitForDiagnostics+      actionsOrCommands <- getAllCodeActions originalDoc+      for_ excludedActions (\a -> assertNoActionWithTitle a actionsOrCommands)+      chosenAction <- pickActionWithTitle action actionsOrCommands+      executeCodeAction chosenAction+      originalDocAfterAction <- documentContents originalDoc+      liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction++renameActionTests :: TestTree+renameActionTests = testGroup "rename actions"+  [ check "change to local variable name"+      [ "module Testing where"+      , "foo :: Int -> Int"+      , "foo argName = argNme"+      ]+      ("Replace with ‘argName’", R 2 14 2 20)+      [ "module Testing where"+      , "foo :: Int -> Int"+      , "foo argName = argName"+      ]+  , check "change to name of imported function"+      [ "module Testing where"+      , "import Data.Maybe (maybeToList)"+      , "foo :: Maybe a -> [a]"+      , "foo = maybToList"+      ]+      ("Replace with ‘maybeToList’", R 3 6 3 16)+      [ "module Testing where"+      , "import Data.Maybe (maybeToList)"+      , "foo :: Maybe a -> [a]"+      , "foo = maybeToList"+      ]+  , check "change infix function"+      [ "module Testing where"+      , "monus :: Int -> Int"+      , "monus x y = max 0 (x - y)"+      , "foo x y = x `monnus` y"+      ]+      ("Replace with ‘monus’", R 3 12 3 20)+      [ "module Testing where"+      , "monus :: Int -> Int"+      , "monus x y = max 0 (x - y)"+      , "foo x y = x `monus` y"+      ]+  , check "change template function"+      [ "{-# LANGUAGE TemplateHaskellQuotes #-}"+      , "module Testing where"+      , "import Language.Haskell.TH (Name)"+      , "foo :: Name"+      , "foo = 'bread"+      ]+      ("Replace with ‘break’", R 4 6 4 12)+      [ "{-# LANGUAGE TemplateHaskellQuotes #-}"+      , "module Testing where"+      , "import Language.Haskell.TH (Name)"+      , "foo :: Name"+      , "foo = 'break"+      ]+  , testSession "suggest multiple local variable names" $ do+      doc <- createDoc "Testing.hs" "haskell" $ T.unlines+            [ "module Testing where"+            , "foo :: Char -> Char -> Char -> Char"+            , "foo argument1 argument2 argument3 = argumentX"+            ]+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (R 2 36 2 45)+      traverse_ (assertActionWithTitle actions)+        [ "Replace with ‘argument1’"+        , "Replace with ‘argument2’"+        , "Replace with ‘argument3’"+        ]+  ]+  where+    check :: TestName -> [T.Text] -> (T.Text, Range) -> [T.Text] -> TestTree+    check testName linesOrig (actionTitle, actionRange) linesExpected  =+      testSession testName $ do+        let contentBefore = T.unlines linesOrig+        doc <- createDoc "Testing.hs" "haskell" contentBefore+        _ <- waitForDiagnostics+        action <- pickActionWithTitle actionTitle =<< getCodeActions doc actionRange+        executeCodeAction action+        contentAfter <- documentContents doc+        let expectedContent = T.unlines linesExpected+        liftIO $ expectedContent @=? contentAfter++typeWildCardActionTests :: TestTree+typeWildCardActionTests = testGroup "type wildcard actions"+  [ testUseTypeSignature "global signature"+        [ "func :: _"+        , "func x = x"+        ]+        [ "func :: p -> p"+        , "func x = x"+        ]+  , testUseTypeSignature "local signature"+        [ "func :: Int -> Int"+        , "func x ="+        , "  let y :: _"+        , "      y = x * 2"+        , "  in y"+        ]+        [ "func :: Int -> Int"+        , "func x ="+        , "  let y :: Int"+        , "      y = x * 2"+        , "  in y"+        ]+  , testUseTypeSignature "multi-line message 1"+        [ "func :: _"+        , "func x y = x + y"+        ]+        [ if ghcVersion >= GHC98+          then "func :: a -> a -> a" -- 9.8 has a different suggestion+          else "func :: Integer -> Integer -> Integer"+        , "func x y = x + y"+        ]+  , testUseTypeSignature "type in parentheses"+        [ "func :: a -> _"+        , "func x = (x, const x)"+        ]+        [ "func :: a -> (a, b -> a)"+        , "func x = (x, const x)"+        ]+  , testUseTypeSignature "type in brackets"+        [ "func :: _ -> Maybe a"+        , "func xs = head xs"+        ]+        [ "func :: [Maybe a] -> Maybe a"+        , "func xs = head xs"+        ]+  , testUseTypeSignature "unit type"+        [ "func :: IO _"+        , "func = putChar 'H'"+        ]+        [ "func :: IO ()"+        , "func = putChar 'H'"+        ]+  , testUseTypeSignature "no spaces around '::'"+        [ "func::_"+        , "func x y = x + y"+        ]+        [ if ghcVersion >= GHC98+          then "func::a -> a -> a" -- 9.8 has a different suggestion+          else "func::Integer -> Integer -> Integer"+        , "func x y = x + y"+        ]+  , testGroup "add parens if hole is part of bigger type"+    [ testUseTypeSignature "subtype 1"+          [ "func :: _ -> Integer -> Integer"+          , "func x y = x + y"+          ]+          [ "func :: Integer -> Integer -> Integer"+          , "func x y = x + y"+          ]+    , testUseTypeSignature "subtype 2"+          [ "func :: Integer -> _ -> Integer"+          , "func x y = x + y"+          ]+          [ "func :: Integer -> Integer -> Integer"+          , "func x y = x + y"+          ]+    , testUseTypeSignature "subtype 3"+          [ "func :: Integer -> Integer -> _"+          , "func x y = x + y"+          ]+          [ "func :: Integer -> Integer -> Integer"+          , "func x y = x + y"+          ]+    , testUseTypeSignature "subtype 4"+          [ "func :: Integer -> _"+          , "func x y = x + y"+          ]+          [ "func :: Integer -> (Integer -> Integer)"+          , "func x y = x + y"+          ]+    ]+  ]+  where+    -- | Test session of given name, checking action "Use type signature..."+    --   on a test file with given content and comparing to expected result.+    testUseTypeSignature name textIn textOut = testSession name $ do+        let fileStart = "module Testing where"+            content = T.unlines $ fileStart : textIn+            expectedContentAfterAction = T.unlines $ fileStart : textOut+        doc <- createDoc "Testing.hs" "haskell" content+        _ <- waitForDiagnostics+        actionsOrCommands <- getAllCodeActions doc+        [addSignature] <- pure [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands+                                       , "Use type signature" `T.isPrefixOf` actionTitle+                               ]+        executeCodeAction addSignature+        contentAfterAction <- documentContents doc+        liftIO $ expectedContentAfterAction @=? contentAfterAction+++removeImportTests :: TestTree+removeImportTests = testGroup "remove import actions"+  [ testSession "redundant" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "qualified redundant" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant binding" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "stuffA = False"+            , "stuffB :: Integer"+            , "stuffB = 123"+            , "stuffC = ()"+            , "_stuffD = '_'"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)"+            , "main = print stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove _stuffD, stuffA, stuffC from import"+          =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant binding - unicode regression " $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A"+            , "ε :: Double"+            , "ε = 0.5"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (A(..), ε)"+            , "a = A"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove ε from import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (A(..))"+            , "a = A"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant operator" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "a !! _b = a"+            , "a <?> _b = a"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"+            , "main = print A.stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove !!, <?> from import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A (stuffB)"+            , "main = print A.stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant all import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (A(..), stuffB)"+            , "main = print stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove A from import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant constructor import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data D = A | B"+            , "data E = F"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (D(A,B), E(F))"+            , "main = B"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove A, E, F from import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (D(B))"+            , "main = B"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "import containing the identifier Strict" $ do+      let contentA = T.unlines+            [ "module Strict where"+            ]+      _docA <- createDoc "Strict.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import Strict"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "remove all" $ do+      let content = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleA where"+            , "import Data.Function (fix, (&))"+            , "import qualified Data.Functor.Const"+            , "import Data.Functor.Identity"+            , "import Data.Functor.Sum (Sum (InL, InR))"+            , "import qualified Data.Kind as K (Constraint, Type)"+            , "x = InL (Identity 123)"+            , "y = fix id"+            , "type T = K.Type"+            ]+      doc <- createDoc "ModuleC.hs" "haskell" content+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove all redundant imports" =<< getAllCodeActions doc+      executeCodeAction action+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleA where"+            , "import Data.Function (fix)"+            , "import Data.Functor.Identity"+            , "import Data.Functor.Sum (Sum (InL))"+            , "import qualified Data.Kind as K (Type)"+            , "x = InL (Identity 123)"+            , "y = fix id"+            , "type T = K.Type"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "remove unused operators whose name ends with '.'" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "(@.) = 0 -- Must have an operator whose name ends with '.'"+            , "a = 1 -- .. but also something else"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (a, (@.))"+            , "x = a -- Must use something from module A, but not (@.)"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove @. from import" =<< getCodeActions docB (R 2 0 2 5)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (a)"+            , "x = a -- Must use something from module A, but not (@.)"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  ]++extendImportTests :: TestTree+extendImportTests = testGroup "extend import actions"+  [ testGroup "with checkAll" $ tests True+  , testGroup "without checkAll" $ tests False+  ]+  where+    tests overrideCheckProject =+        [ testSession "extend all constructors for record field" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = B { a :: Int }"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A(B))"+                    , "f = a"+                    ])+            (Range (Position 2 4) (Position 2 5))+            [ "Add A(..) to the import list of ModuleA"+            , "Add A(a) to the import list of ModuleA"+            , "Add a to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A(..))"+                    , "f = a"+                    ])+        , testSession "extend all constructors with sibling" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data Foo"+                    , "data Bar"+                    , "data A = B | C"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ( Foo,  A (C) , Bar ) "+                    , "f = B"+                    ])+            (Range (Position 2 4) (Position 2 5))+            [ "Add A(..) to the import list of ModuleA"+            , "Add A(B) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ( Foo,  A (..) , Bar ) "+                    , "f = B"+                    ])+        , testSession "extend all constructors with comment" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data Foo"+                    , "data Bar"+                    , "data A = B | C"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ( Foo,  A (C{-comment--}) , Bar ) "+                    , "f = B"+                    ])+            (Range (Position 2 4) (Position 2 5))+            [ "Add A(..) to the import list of ModuleA"+            , "Add A(B) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ( Foo,  A (..{-comment--}) , Bar ) "+                    , "f = B"+                    ])+        , testSession "extend all constructors for type operator" $ template+            []+            ("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "import Data.Type.Equality ((:~:))"+                    , "x :: (:~:) [] []"+                    , "x = Refl"+                    ])+            (Range (Position 3 17) (Position 3 18))+            [ "Add (:~:)(..) to the import list of Data.Type.Equality"+            , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]+            (T.unlines+                    [ "module ModuleA where"+                    , "import Data.Type.Equality ((:~:) (..))"+                    , "x :: (:~:) [] []"+                    , "x = Refl"+                    ])+        , testSession "extend all constructors for class" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "class C a where"+                    , "  m1 :: a -> a"+                    , "  m2 :: a -> a"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1))"+                    , "b = m2"+                    ])+            (Range (Position 2 5) (Position 2 5))+            [ "Add C(..) to the import list of ModuleA"+            , "Add C(m2) to the import list of ModuleA"+            , "Add m2 to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(..))"+                    , "b = m2"+                    ])+        , testSession "extend single line import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB)"+                    , "main = print (stuffA, stuffB)"+                    ])+            (Range (Position 2 17) (Position 2 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB, stuffA)"+                    , "main = print (stuffA, stuffB)"+                    ])+        , testSession "extend single line import with operator" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "(.*) :: Integer -> Integer -> Integer"+                    , "x .* y = x * y"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB)"+                    , "main = print (stuffB .* stuffB)"+                    ])+            (Range (Position 2 17) (Position 2 18))+            ["Add (.*) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB, (.*))"+                    , "main = print (stuffB .* stuffB)"+                    ])+        , testSession "extend single line import with infix constructor" $ template+            []+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import Data.List.NonEmpty (fromList)"+                    , "main = case (fromList []) of _ :| _ -> pure ()"+                    ])+            (Range (Position 2 5) (Position 2 6))+            [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"+            , "Add NonEmpty(..) to the import list of Data.List.NonEmpty"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))"+                    , "main = case (fromList []) of _ :| _ -> pure ()"+                    ])+        , testSession "extend single line import with prefix constructor" $ template+            []+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import Prelude hiding (Maybe(..))"+                    , "import Data.Maybe (catMaybes)"+                    , "x = Just 10"+                    ])+            (Range (Position 3 5) (Position 2 6))+            [ "Add Maybe(Just) to the import list of Data.Maybe"+            , "Add Maybe(..) to the import list of Data.Maybe"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import Prelude hiding (Maybe(..))"+                    , "import Data.Maybe (catMaybes, Maybe (Just))"+                    , "x = Just 10"+                    ])+        , testSession "extend single line import with type" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "type A = Double"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ()"+                    , "b :: A"+                    , "b = 0"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add A to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A)"+                    , "b :: A"+                    , "b = 0"+                    ])+        , testSession "extend single line import with constructor" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = Constructor"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A)"+                    , "b :: A"+                    , "b = Constructor"+                    ])+            (Range (Position 3 5) (Position 3 5))+            [ "Add A(Constructor) to the import list of ModuleA"+            , "Add A(..) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A (Constructor))"+                    , "b :: A"+                    , "b = Constructor"+                    ])+        , testSession "extend single line import with constructor (with comments)" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = Constructor"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A ({-Constructor-}))"+                    , "b :: A"+                    , "b = Constructor"+                    ])+            (Range (Position 3 5) (Position 3 5))+            [ "Add A(Constructor) to the import list of ModuleA"+            , "Add A(..) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A (Constructor{-Constructor-}))"+                    , "b :: A"+                    , "b = Constructor"+                    ])+        , testSession "extend single line import with mixed constructors" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = ConstructorFoo | ConstructorBar"+                    , "a = 1"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A (ConstructorBar), a)"+                    , "b :: A"+                    , "b = ConstructorFoo"+                    ])+            (Range (Position 3 5) (Position 3 5))+            [ "Add A(ConstructorFoo) to the import list of ModuleA"+            , "Add A(..) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)"+                    , "b :: A"+                    , "b = ConstructorFoo"+                    ])+        , brokenForGHC92 "On GHC 9.2, the error doesn't contain \"perhaps you want ...\" part from which import suggestion can be extracted." $+          testSession "extend single line import in presence of extra parens" $ template+            []+            ("Main.hs", T.unlines+                    [ "import Data.Monoid (First)"+                    , "f = (First Nothing) <> mempty" -- parens tripped up the regex extracting import suggestions+                    ])+            (Range (Position 1 6) (Position 1 7))+            [ "Add First(..) to the import list of Data.Monoid"+            , "Add First(First) to the import list of Data.Monoid"+            ]+            (T.unlines+                    [ "import Data.Monoid (First (..))"+                    , "f = (First Nothing) <> mempty"+                    ])+        , brokenForGHC94 "On GHC 9.4, the error messages with -fdefer-type-errors don't have necessary imported target srcspan info." $+          testSession "extend single line qualified import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import qualified ModuleA as A (stuffB)"+                    , "main = print (A.stuffA, A.stuffB)"+                    ])+            (Range (Position 2 17) (Position 2 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import qualified ModuleA as A (stuffB, stuffA)"+                    , "main = print (A.stuffA, A.stuffB)"+                    ])+        , testSession "extend multi line import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffB"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffB, stuffA"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+        , testSession "extend multi line import with trailing comma" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffB,"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffB, stuffA,"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+        , testSession "extend single line import with method within class" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "class C a where"+                    , "  m1 :: a -> a"+                    , "  m2 :: a -> a"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1))"+                    , "b = m2"+                    ])+            (Range (Position 2 5) (Position 2 5))+            [ "Add C(m2) to the import list of ModuleA"+            , "Add m2 to the import list of ModuleA"+            , "Add C(..) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1, m2))"+                    , "b = m2"+                    ])+        , testSession "extend single line import with method without class" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "class C a where"+                    , "  m1 :: a -> a"+                    , "  m2 :: a -> a"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1))"+                    , "b = m2"+                    ])+            (Range (Position 2 5) (Position 2 5))+            [ "Add m2 to the import list of ModuleA"+            , "Add C(m2) to the import list of ModuleA"+            , "Add C(..) to the import list of ModuleA"+            ]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1), m2)"+                    , "b = m2"+                    ])+        , testSession "extend import list with multiple choices" $ template+            [("ModuleA.hs", T.unlines+                    --  this is just a dummy module to help the arguments needed for this test+                    [  "module ModuleA (bar) where"+                    , "bar = 10"+                    ]),+            ("ModuleB.hs", T.unlines+                    --  this is just a dummy module to help the arguments needed for this test+                    [  "module ModuleB (bar) where"+                    , "bar = 10"+                    ])]+            ("ModuleC.hs", T.unlines+                    [ "module ModuleC where"+                    , "import ModuleB ()"+                    , "import ModuleA ()"+                    , "foo = bar"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add bar to the import list of ModuleA",+            "Add bar to the import list of ModuleB"]+            (T.unlines+                    [ "module ModuleC where"+                    , "import ModuleB ()"+                    , "import ModuleA (bar)"+                    , "foo = bar"+                    ])+        , testSession "extend import list with constructor of type operator" $ template+            []+            ("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "import Data.Type.Equality ((:~:))"+                    , "x :: (:~:) [] []"+                    , "x = Refl"+                    ])+            (Range (Position 3 17) (Position 3 18))+            [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"+            , "Add (:~:)(..) to the import list of Data.Type.Equality"]+            (T.unlines+                    [ "module ModuleA where"+                    , "import Data.Type.Equality ((:~:) (Refl))"+                    , "x :: (:~:) [] []"+                    , "x = Refl"+                    ])+        , expectFailBecause "importing pattern synonyms is unsupported"+          $ testSession "extend import list with pattern synonym" $ template+            [("ModuleA.hs", T.unlines+                    [ "{-# LANGUAGE PatternSynonyms #-}"+                      , "module ModuleA where"+                      , "pattern Some x = Just x"+                    ])+            ]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import A ()"+                    , "k (Some x) = x"+                    ])+            (Range (Position 2 3) (Position 2 7))+            ["Add pattern Some to the import list of A"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import A (pattern Some)"+                    , "k (Some x) = x"+                    ])+        , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $+          testSession "type constructor name same as data constructor name" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "newtype Foo = Foo Int"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA(Foo)"+                    , "f :: Foo"+                    , "f = Foo 1"+                    ])+            (Range (Position 3 4) (Position 3 6))+            ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA(Foo (Foo))"+                    , "f :: Foo"+                    , "f = Foo 1"+                    ])+        , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data Foo = Foo"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA()"+                    , "f :: Foo"+                    , "f = undefined"+                    ])+            (Range (Position 2 4) (Position 2 6))+            ["Add Foo to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA(Foo)"+                    , "f :: Foo"+                    , "f = undefined"+                    ])+        ]+      where+        codeActionTitle CodeAction{_title=x} = x++        template setUpModules moduleUnderTest range expectedTitles expectedContentB = do+            configureCheckProject overrideCheckProject++            mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules+            docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)+            _  <- waitForDiagnostics+            waitForProgressDone+            actionsOrCommands <- getCodeActions docB range+            let codeActions =+                  [ ca | InR ca <- actionsOrCommands+                  , let title = codeActionTitle ca+                  , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title)+                  ]+                actualTitles = codeActionTitle <$> codeActions+            -- Note that we are not testing the order of the actions, as the+            -- order of the expected actions indicates which one we'll execute+            -- in this test, i.e., the first one.+            liftIO $ sort expectedTitles @=? sort actualTitles++            -- Execute the action with the same title as the first expected one.+            -- Since we tested that both lists have the same elements (possibly+            -- in a different order), this search cannot fail.+            firstTitle:_ <- pure expectedTitles+            Just action <- pure $ find ((firstTitle ==) . codeActionTitle) codeActions+            executeCodeAction action+            contentAfterAction <- documentContents docB+            liftIO $ expectedContentB @=? contentAfterAction++fixModuleImportTypoTests :: TestTree+fixModuleImportTypoTests = testGroup "fix module import typo"+    [ testSession "works when single module suggested" $ do+        doc <- createDoc "A.hs" "haskell" "import Data.Cha"+        _ <- waitForDiagnostics+        action <- pickActionWithTitle "replace with Data.Char" =<< getCodeActions doc (R 0 0 0 10)+        executeCodeAction action+        contentAfterAction <- documentContents doc+        liftIO $ contentAfterAction @?= "import Data.Char"+    , testSession "works when multiple modules suggested" $ do+        doc <- createDoc "A.hs" "haskell" "import Data.I"+        _ <- waitForDiagnostics+        actions <- getCodeActions doc (R 0 0 0 10)+        traverse_ (assertActionWithTitle actions)+          [ "replace with Data.Eq"+          , "replace with Data.Int"+          , "replace with Data.Ix"+          ]+        replaceWithDataEq <- pickActionWithTitle "replace with Data.Eq" actions+        executeCodeAction replaceWithDataEq+        contentAfterAction <- documentContents doc+        liftIO $ contentAfterAction @?= "import Data.Eq"+    ]++suggestImportClassMethodTests :: TestTree+suggestImportClassMethodTests =+  testGroup+    "suggest import class methods"+    [ testGroup+        "new"+        [ testSession "via parent" $+            template'+            "import Data.Semigroup (Semigroup(stimes))"+            (Range (Position 4 2) (Position 4 8)),+          testSession "top level" $+            template'+              "import Data.Semigroup (stimes)"+              (Range (Position 4 2) (Position 4 8)),+          testSession "all" $+            template'+              "import Data.Semigroup"+              (Range (Position 4 2) (Position 4 8))+        ],+      testGroup+        "extend"+        [ testSession "via parent" $+            template+              [ "module A where",+                "",+                "import Data.Semigroup ()"+              ]+              (Range (Position 6 2) (Position 6 8))+              "Add Semigroup(stimes) to the import list of Data.Semigroup"+              [ "module A where",+                "",+                "import Data.Semigroup (Semigroup (stimes))"+              ],+          testSession "top level" $+            template+              [ "module A where",+                "",+                "import Data.Semigroup ()"+              ]+              (Range (Position 6 2) (Position 6 8))+              "Add stimes to the import list of Data.Semigroup"+              [ "module A where",+                "",+                "import Data.Semigroup (stimes)"+              ]+        ]+    ]+  where+    decls =+      [ "data X = X",+        "instance Semigroup X where",+        "  (<>) _ _ = X",+        "  stimes _ _ = X"+      ]+    template beforeContent range executeTitle expectedContent = do+      doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls)+      _ <- waitForDiagnostics+      waitForProgressDone+      action <- pickActionWithTitle executeTitle =<< getCodeActions doc range+      executeCodeAction action+      content <- documentContents doc+      liftIO $ T.unlines (expectedContent <> decls) @=? content+    template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle]++suggestImportTests :: TestTree+suggestImportTests = testGroup "suggest import actions"+  [ testGroup "Dont want suggestion"+    [ -- extend import+      -- We don't want to suggest a new import, but extend existing imports+      test False ["Data.List.NonEmpty ()"] "f = nonEmpty" []                "import Data.List.NonEmpty (nonEmpty)"+      -- data constructor+    , test False []                        "f = First"    []                "import Data.Monoid (First)"+      -- internal module+    , test False []         "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable.Internal (Typeable)"+      -- package not in scope+    , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"+      -- don't omit the parent data type of a constructor+    , test False []         "f ExitSuccess = ()"          []                "import System.Exit (ExitSuccess)"+      -- don't suggest data constructor when we only need the type+    , test False []         "f :: Bar"                    []                "import Bar (Bar(Bar))"+      -- don't suggest all data constructors for the data type+    , test False []         "f :: Bar"                    []                "import Bar (Bar(..))"+    ]+  , testGroup "want suggestion"+    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"+    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"+    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"+    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(..))"+    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"+    , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"+    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"+    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"+    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"+    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"+    , test True []          "f = First"                   []                "import Data.Monoid (First(First))"+    , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"+    , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"+    , test True []          "f ExitSuccess = ()"          []                "import System.Exit (ExitCode(ExitSuccess))"+    , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"+    , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"+    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"+    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"+    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"+    , test True []          "f = empty"                   []                "import Control.Applicative (empty)"+    , test True []          "f = empty"                   []                "import Control.Applicative"+    , test True []          "f = (&)"                     []                "import Data.Function ((&))"+    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"+    , test True []          "f = (NE.:|)"                 []                "import qualified Data.List.NonEmpty as NE"+    , test True []          "f = (Data.List.NonEmpty.:|)" []                "import qualified Data.List.NonEmpty"+    , test True []          "f = (B..|.)"                 []                "import qualified Data.Bits as B"+    , test True []          "f = (Data.Bits..|.)"         []                "import qualified Data.Bits"+    , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"+    , test True []          "f = pack"                    []                "import Data.Text (pack)"+    , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"+    , test True []          "f = [] & id"                 []                "import Data.Function ((&))"+    , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"+    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"+    , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"+    , test True []          "f :: a ~~ b"                 []                "import Data.Type.Equality ((~~))"+    , test True+      ["qualified Data.Text as T"+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"+    , test True+      [ "qualified Data.Text as T"+      , "qualified Data.Function as T"+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"+    , test True+      [ "qualified Data.Text as T"+      , "qualified Data.Function as T"+      , "qualified Data.Functor as T"+      , "qualified Data.Data as T"+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"+    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits(..))"+    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(..))"+    ]+  , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"+  ]+  where+    test = test' False+    wantWait = test' True True++    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do+      configureCheckProject waitForCheckProject+      let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other+          after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle+      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]+      doc <- createDoc "Test.hs" "haskell" before+      waitForProgressDone+      _ <- waitForDiagnostics+      -- there isn't a good way to wait until the whole project is checked atm+      when waitForCheckProject $ liftIO $ sleep 0.5+      let defLine = fromIntegral $ length imps + 1+          range = Range (Position defLine 0) (Position defLine maxBound)+      actions <- getCodeActions doc range+      if wanted+         then do+             action <- pickActionWithTitle newImp actions+             executeCodeAction action+             contentAfterAction <- documentContents doc+             liftIO $ after @=? contentAfterAction+          else+              liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= []++suggestAddRecordFieldImportTests :: TestTree+suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot"+  [ testGroup "The field is suggested when an instance resolution failure occurs"+    [ ignoreForGhcVersions [GHC90, GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest+    ]+  ]+  where+    theTest = testSessionWithExtraFiles "hover" def $ \dir -> do+      configureCheckProject False+      let before = T.unlines ["module A where", "import B (Foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"]+          after  = T.unlines ["module A where", "import B (Foo, foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"]+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, B]}}"+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle+      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["module B where", "data Foo = Foo { foo :: Int }"]+      doc <- createDoc "Test.hs" "haskell" before+      waitForProgressDone+      _ <- waitForDiagnostics+      let defLine = 3+          range = Range (Position defLine 0) (Position defLine maxBound)+      actions <- getCodeActions doc range+      action <- pickActionWithTitle "Add foo to the import list of B" actions+      executeCodeAction action+      contentAfterAction <- documentContents doc+      liftIO $ after @=? contentAfterAction+++suggestImportDisambiguationTests :: TestTree+suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions"+  [ testGroup "Hiding strategy works"+    [ testGroup "fromList"+        [ testCase "AVec" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Use AVec for fromList, hiding other imports"+                "HideFunction.expected.fromList.A.hs"+        , testCase "BVec" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Use BVec for fromList, hiding other imports"+                "HideFunction.expected.fromList.B.hs"+        ]+    , testGroup "(++)"+        [ testCase "EVec" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Use EVec for ++, hiding other imports"+                "HideFunction.expected.append.E.hs"+        , testCase "Hide functions without local" $+            compareTwo+                "HideFunctionWithoutLocal.hs" [(8,8)]+                "Use local definition for ++, hiding other imports"+                "HideFunctionWithoutLocal.expected.hs"+        , testCase "Prelude" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Use Prelude for ++, hiding other imports"+                "HideFunction.expected.append.Prelude.hs"+        , testCase "Prelude and local definition, infix" $+            compareTwo+                "HidePreludeLocalInfix.hs" [(2,19)]+                "Use local definition for ++, hiding other imports"+                "HidePreludeLocalInfix.expected.hs"+        , testCase "AVec, indented" $+            compareTwo "HidePreludeIndented.hs" [(3,8)]+            "Use AVec for ++, hiding other imports"+            "HidePreludeIndented.expected.hs"+        ]+    , testGroup "Vec (type)"+        [ testCase "AVec" $+            compareTwo+                "HideType.hs" [(8,15)]+                "Use AVec for Vec, hiding other imports"+                "HideType.expected.A.hs"+        , testCase "EVec" $+            compareTwo+                "HideType.hs" [(8,15)]+                "Use EVec for Vec, hiding other imports"+                "HideType.expected.E.hs"+        ]+    ]+  , testGroup "Qualify strategy"+    [ testCase "won't suggest full name for qualified module" $+      withHideFunction [(8,9),(10,8)] $ \_ _ actions -> do+        liftIO $+            assertBool "EVec.fromList must not be suggested" $+                "Replace with qualified: EVec.fromList" `notElem`+                [ actionTitle+                | InR CodeAction { _title = actionTitle } <- actions+                ]+        liftIO $+            assertBool "EVec.++ must not be suggested" $+                "Replace with qualified: EVec.++" `notElem`+                [ actionTitle+                | InR CodeAction { _title = actionTitle } <- actions+                ]+    , testGroup "fromList"+        [ testCase "EVec" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Replace with qualified: E.fromList"+                "HideFunction.expected.qualified.fromList.E.hs"+        , testCase "Hide DuplicateRecordFields" $+            compareTwo+                "HideQualifyDuplicateRecordFields.hs" [(9, 9)]+                "Replace with qualified: AVec.fromList"+                "HideQualifyDuplicateRecordFields.expected.hs"+        , testCase "Duplicate record fields should not be imported" $ do+          withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $+            \_ _ actions -> do+              liftIO $+                assertBool "Hidings should not be presented while DuplicateRecordFields exists" $+                  all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports"+                      | InR CodeAction { _title = actionTitle } <- actions]+          withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $+            \_ _ actions -> do+              liftIO $+                assertBool "ambiguity from DuplicateRecordFields should not be imported" $+                  null actions+        ]+    , testGroup "(++)"+        [ testCase "Prelude, parensed" $+            compareHideFunctionTo [(8,9),(10,8)]+                "Replace with qualified: Prelude.++"+                "HideFunction.expected.qualified.append.Prelude.hs"+        , testCase "Prelude, infix" $+            compareTwo+                "HideQualifyInfix.hs" [(4,19)]+                "Replace with qualified: Prelude.++"+                "HideQualifyInfix.expected.hs"+        , testCase "Prelude, left section" $+            compareTwo+                "HideQualifySectionLeft.hs" [(4,15)]+                "Replace with qualified: Prelude.++"+                "HideQualifySectionLeft.expected.hs"+        , testCase "Prelude, right section" $+            compareTwo+                "HideQualifySectionRight.hs" [(4,18)]+                "Replace with qualified: Prelude.++"+                "HideQualifySectionRight.expected.hs"+        ]+    ]+  ]+  where+    compareTwo original locs cmd expected =+        withTarget original locs $ \dir doc actions -> do+            expected <- liftIO $+                readFileUtf8 (dir </> expected)+            action <- pickActionWithTitle cmd actions+            executeCodeAction action+            contentAfterAction <- documentContents doc+            liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction+    compareHideFunctionTo = compareTwo "HideFunction.hs"+    withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do+        doc <- openDoc file "haskell"+        void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence") | loc <- locs])]+        actions <- getAllCodeActions doc+        k dir doc actions+    withHideFunction = withTarget ("HideFunction" <.> "hs")++suggestHideShadowTests :: TestTree+suggestHideShadowTests =+  testGroup+    "suggest hide shadow"+    [ testGroup+        "single"+        [ testOneCodeAction+            "hide unused"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function"+            , "f on = on"+            , "g on = on"+            ]+            [ "import Data.Function hiding (on)"+            , "f on = on"+            , "g on = on"+            ]+        , testOneCodeAction+            "extend hiding unused"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function hiding ((&))"+            , "f on = on"+            ]+            [ "import Data.Function hiding (on, (&))"+            , "f on = on"+            ]+        , testOneCodeAction+            "delete unused"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function ((&), on)"+            , "f on = on"+            ]+            [ "import Data.Function ((&))"+            , "f on = on"+            ]+        , testOneCodeAction+            "hide operator"+            "Hide & from Data.Function"+            (1, 2)+            (1, 5)+            [ "import Data.Function"+            , "f (&) = (&)"+            ]+            [ "import Data.Function hiding ((&))"+            , "f (&) = (&)"+            ]+        , testOneCodeAction+            "remove operator"+            "Hide & from Data.Function"+            (1, 2)+            (1, 5)+            [ "import Data.Function ((&), on)"+            , "f (&) = (&)"+            ]+            [ "import Data.Function ( on)"+            , "f (&) = (&)"+            ]+        , noCodeAction+            "don't remove already used"+            (2, 2)+            (2, 4)+            [ "import Data.Function"+            , "g = on"+            , "f on = on"+            ]+        ]+    , testGroup+        "multi"+        [ testOneCodeAction+            "hide from B"+            "Hide ++ from B"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "hide from C"+            "Hide ++ from C"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B"+            , "import C hiding ((++))"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "hide from Prelude"+            "Hide ++ from Prelude"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B"+            , "import C"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        , testMultiCodeActions+            "manual hide all"+            [ "Hide ++ from Prelude"+            , "Hide ++ from C"+            , "Hide ++ from B"+            ]+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C hiding ((++))"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "auto hide all"+            "Hide ++ from all occurrence imports"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C hiding ((++))"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        ]+    ]+ where+  testOneCodeAction testName actionName start end origin expected =+    helper testName start end origin expected $ \cas -> do+      action <- pickActionWithTitle actionName cas+      executeCodeAction action+  noCodeAction testName start end origin =+    helper testName start end origin origin $ \cas -> do+      liftIO $ cas @?= []+  testMultiCodeActions testName actionNames start end origin expected =+    helper testName start end origin expected $ \cas -> do+      let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames]+      liftIO $+        (length r == length actionNames)+          @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset"+      forM_ r executeCodeAction+  helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do+    void $ createDoc "B.hs" "haskell" $ T.unlines docB+    void $ createDoc "C.hs" "haskell" $ T.unlines docC+    doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin)+    void waitForDiagnostics+    waitForProgressDone+    cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2))+    void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)]+    contentAfter <- documentContents doc+    liftIO $ contentAfter @?= T.unlines (header <> expected)+  header =+    [ "{-# OPTIONS_GHC -Wname-shadowing #-}"+    , "module A where"+    , ""+    ]+  -- for multi group+  docB =+    [ "module B where"+    , "(++) = id"+    ]+  docC =+    [ "module C where"+    , "(++) = id"+    ]++insertNewDefinitionTests :: TestTree+insertNewDefinitionTests = testGroup "insert new definition actions"+  [ testSession "insert new function definition" $ do+      let txtB =+            ["foo True = select [True]"+            , ""+            ,"foo False = False"+            ]+          txtB' =+            [""+            ,"someOtherCode = ()"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Define select :: [Bool] -> Bool"+          =<< getCodeActions docB (R 0 0 0 50)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ contentAfterAction @?= T.unlines (txtB +++        [ ""+        , "select :: [Bool] -> Bool"+        , "select = _"+        ]+        ++ txtB')+  , testSession "insert new function definition - with similar suggestion in scope" $ do+      doc <- createDoc "Module.hs" "haskell" $ T.unlines+          [ "import Control.Monad" -- brings `mplus` into scope, leading to additional suggestion+                                   -- "Perhaps use \8216mplus\8217 (imported from Control.Monad)"+          , "f :: Int -> Int"+          , "f x = plus x x"+          ]+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Define plus :: Int -> Int -> Int"+          =<< getCodeActions doc (R 2 0 2 13)+      executeCodeAction action+      contentAfterAction <- documentContents doc+      liftIO $ contentAfterAction @?= T.unlines+          [ "import Control.Monad"+          , "f :: Int -> Int"+          , "f x = plus x x"+          , ""+          , "plus :: Int -> Int -> Int"+          , "plus = _"+          ]+  , testSession "define a hole" $ do+      let txtB =+            ["foo True = _select [True]"+            , ""+            ,"foo False = False"+            ]+          txtB' =+            [""+            ,"someOtherCode = ()"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Define select :: [Bool] -> Bool"+          =<< getCodeActions docB (R 0 0 0 50)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ contentAfterAction @?= T.unlines (+        ["foo True = select [True]"+        , ""+        ,"foo False = False"+        , ""+        , "select :: [Bool] -> Bool"+        , "select = _"+        ]+        ++ txtB')+  , testSession "insert new function definition - Haddock comments" $ do+    let start = [ "foo :: Int -> Bool"+                 , "foo x = select (x + 1)"+                 , ""+                 , "-- | This is a haddock comment"+                 , "haddock :: Int -> Int"+                 , "haddock = undefined"+                 ]+    let expected =  ["foo :: Int -> Bool"+             , "foo x = select (x + 1)"+             , ""+             , "select :: Int -> Bool"+             , "select = _"+             , ""+             , "-- | This is a haddock comment"+             , "haddock :: Int -> Int"+             , "haddock = undefined"+             ]+    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)+    _ <- waitForDiagnostics+    action <- pickActionWithTitle "Define select :: Int -> Bool"+            =<< getCodeActions docB (R 1 0 0 50)+    executeCodeAction action+    contentAfterAction <- documentContents docB+    liftIO $ contentAfterAction @?= T.unlines expected+  , testSession "insert new function definition - normal comments" $ do+    let start =  ["foo :: Int -> Bool"+                 , "foo x = select (x + 1)"+                 , ""+                 , "-- This is a normal comment"+                 , "normal :: Int -> Int"+                 , "normal = undefined"+                 ]+    let expected =  ["foo :: Int -> Bool"+             , "foo x = select (x + 1)"+             , ""+             , "select :: Int -> Bool"+             , "select = _"+             , ""+             , "-- This is a normal comment"+             , "normal :: Int -> Int"+             , "normal = undefined"]+    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)+    _ <- waitForDiagnostics+    action <- pickActionWithTitle "Define select :: Int -> Bool"+        =<< getCodeActions docB (R 1 0 0 50)+    executeCodeAction action+    contentAfterAction <- documentContents docB+    liftIO $ contentAfterAction @?= T.unlines expected+    , testSession "insert new function definition - untyped error" $ do+      let txtB =+            ["foo = select"+            ]+          txtB' =+            [""+            ,"someOtherCode = ()"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Define select :: _" =<< getCodeActions docB (R 0 0 0 50)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ contentAfterAction @?= T.unlines (txtB +++        [ ""+        , "select :: _"+        , "select = _"+        ]+        ++ txtB')+  ]+++deleteUnusedDefinitionTests :: TestTree+deleteUnusedDefinitionTests = testGroup "delete unused definition action"+  [ testSession "delete unused top level binding" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (some) where"+      , ""+      , "f :: Int -> Int"+      , "f 1 = let a = 1"+      , "      in a"+      , "f 2 = 2"+      , ""+      , "some = ()"+      ]+      (4, 0)+      "Delete ‘f’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (some) where"+      , ""+      , "some = ()"+      ]+  , testSession "delete unused top level binding defined in infix form" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (some) where"+      , ""+      , "myPlus :: Int -> Int -> Int"+      , "a `myPlus` b = a + b"+      , ""+      , "some = ()"+      ]+      (4, 2)+      "Delete ‘myPlus’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (some) where"+      , ""+      , "some = ()"+      ]+  , testSession "delete unused binding in where clause" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (h, g) where"+      , ""+      , "h :: Int"+      , "h = 3"+      , ""+      , "g :: Int"+      , "g = 6"+      , "  where"+      , "    h :: Int"+      , "    h = 4"+      , ""+      ]+      (10, 4)+      "Delete ‘h’"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (h, g) where"+      , ""+      , "h :: Int"+      , "h = 3"+      , ""+      , "g :: Int"+      , "g = 6"+      , "  where"+      , ""+      ]+  , testSession "delete unused binding with multi-oneline signatures front" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (b, c) where"+      , ""+      , "a, b, c :: Int"+      , "a = 3"+      , "b = 4"+      , "c = 5"+      ]+      (4, 0)+      "Delete ‘a’"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (b, c) where"+      , ""+      , "b, c :: Int"+      , "b = 4"+      , "c = 5"+      ]+  , testSession "delete unused binding with multi-oneline signatures mid" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, c) where"+      , ""+      , "a, b, c :: Int"+      , "a = 3"+      , "b = 4"+      , "c = 5"+      ]+      (5, 0)+      "Delete ‘b’"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, c) where"+      , ""+      , "a, c :: Int"+      , "a = 3"+      , "c = 5"+      ]+  , testSession "delete unused binding with multi-oneline signatures end" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, b) where"+      , ""+      , "a, b, c :: Int"+      , "a = 3"+      , "b = 4"+      , "c = 5"+      ]+      (6, 0)+      "Delete ‘c’"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, b) where"+      , ""+      , "a, b :: Int"+      , "a = 3"+      , "b = 4"+      ]+  ]+  where+    testFor sourceLines pos@(l,c) expectedTitle expectedLines = do+      docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines+      expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used")]) ]+      action <- pickActionWithTitle expectedTitle =<< getCodeActions docId  (R l c l c)+      executeCodeAction action+      contentAfterAction <- documentContents docId+      liftIO $ contentAfterAction @?= T.unlines expectedLines++addTypeAnnotationsToLiteralsTest :: TestTree+addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints"+  [ testSession "add default type to satisfy one constraint" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A (f) where"+      , ""+      , "f = 1"+      ]+      (if ghcVersion >= GHC94+        then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable") ]+        else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint") ])+      "Add type annotation ‘Integer’ to ‘1’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A (f) where"+      , ""+      , "f = (1 :: Integer)"+      ]++  , testSession "add default type to satisfy one constraint in nested expressions" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A where"+      , ""+      , "f ="+      , "    let x = 3"+      , "    in x"+      ]+      (if ghcVersion >= GHC94+        then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable") ]+        else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint") ])+      "Add type annotation ‘Integer’ to ‘3’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A where"+      , ""+      , "f ="+      , "    let x = (3 :: Integer)"+      , "    in x"+      ]+  , testSession "add default type to satisfy one constraint in more nested expressions" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A where"+      , ""+      , "f ="+      , "    let x = let y = 5 in y"+      , "    in x"+      ]+      (if ghcVersion >= GHC94+        then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable") ]+        else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint") ])+      "Add type annotation ‘Integer’ to ‘5’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "module A where"+      , ""+      , "f ="+      , "    let x = let y = (5 :: Integer) in y"+      , "    in x"+      ]+  , testSession "add default type to satisfy one constraint with duplicate literals" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f = seq \"debug\" traceShow \"debug\""+      ]+      (if ghcVersion >= GHC94+        then+          [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable")+          , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable")+          ]+        else+          [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint")+          , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint")+          ])+      "Add type annotation ‘String’ to ‘\"debug\"’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f = seq (\"debug\" :: String) traceShow \"debug\""+      ]+  , testSession "add default type to satisfy two constraints" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f a = traceShow \"debug\" a"+      ]+      (if ghcVersion >= GHC94+        then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable") ]+        else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint") ])+      "Add type annotation ‘String’ to ‘\"debug\"’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f a = traceShow (\"debug\" :: String) a"+      ]+  , testSession "add default type to satisfy two constraints with duplicate literals" $+    testFor+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"+      ]+      (if ghcVersion >= GHC94+        then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable") ]+        else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint") ])+      "Add type annotation ‘String’ to ‘\"debug\"’"+      [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+      , "{-# LANGUAGE OverloadedStrings #-}"+      , "module A (f) where"+      , ""+      , "import Debug.Trace"+      , ""+      , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: String)))"+      ]+  ]+  where+    testFor sourceLines diag expectedTitle expectedLines = do+      docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines+      expectDiagnostics [ ("A.hs", diag) ]+      let cursors = map snd3 diag+          (ls, cs) = minimum cursors+          (le, ce) = maximum cursors++      action <- pickActionWithTitle expectedTitle =<< getCodeActions docId (R ls cs le ce)+      executeCodeAction action+      contentAfterAction <- documentContents docId+      liftIO $ contentAfterAction @?= T.unlines expectedLines+++fixConstructorImportTests :: TestTree+fixConstructorImportTests = testGroup "fix import actions"+  [ testSession "fix constructor import" $ template+      (T.unlines+            [ "module ModuleA where"+            , "data A = Constructor"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(Constructor)"+            ])+      (Range (Position 1 10) (Position 1 11))+      "Fix import of A(Constructor)"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(A(Constructor))"+            ])+  ]+  where+    template contentA contentB range expectedAction expectedContentB = do+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      docB  <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle expectedAction =<< getCodeActions docB range+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ expectedContentB @=? contentAfterAction++importRenameActionTests :: TestTree+importRenameActionTests = testGroup "import rename actions" $+  fmap check ["Map", "Maybe"]+  where+    check modname = checkCodeAction+      ("Data.Mape -> Data." <> T.unpack modname)+      ("replace with Data." <> modname)+      (T.unlines+        [ "module Testing where"+        , "import Data.Mape"+        ])+      (T.unlines+        [ "module Testing where"+        , "import Data." <> modname+        ])++fillTypedHoleTests :: TestTree+fillTypedHoleTests = let++  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text+  sourceCode a b c = T.unlines+    [ "module Testing where"+    , ""+    , "globalConvert :: Int -> String"+    , "globalConvert = undefined"+    , ""+    , "globalInt :: Int"+    , "globalInt = 3"+    , ""+    , "bar :: Int -> Int -> String"+    , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"+    , "  localConvert = (flip replicate) 'x'"+    , ""+    , "foo :: () -> Int -> String"+    , "foo = undefined"+    ]++  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle+        oldA oldB oldC+        newA newB newC = testSession (T.unpack actionTitle) $ do+    let originalCode = sourceCode oldA oldB oldC+    let expectedCode = sourceCode newA newB newC+    doc <- createDoc "Testing.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))+    chosenAction <- pickActionWithTitle actionTitle actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "fill typed holes"+  [ check "replace _ with show"+          "_"    "n" "n"+          "show" "n" "n"++  , check "replace _ with globalConvert"+          "_"             "n" "n"+          "globalConvert" "n" "n"++  , check "replace _convertme with localConvert"+          "_convertme"   "n" "n"+          "localConvert" "n" "n"++  , check "replace _b with globalInt"+          "_a" "_b"        "_c"+          "_a" "globalInt" "_c"++  , check "replace _c with globalInt"+          "_a" "_b"        "_c"+          "_a" "_b" "globalInt"++  , check "replace _c with parameterInt"+          "_a" "_b" "_c"+          "_a" "_b"  "parameterInt"+  , check "replace _ with foo _"+          "_" "n" "n"+          "(foo _)" "n" "n"+  , testSession "replace _toException with E.toException" $ do+      let mkDoc x = T.unlines+            [ "module Testing where"+            , "import qualified Control.Exception as E"+            , "ioToSome :: E.IOException -> E.SomeException"+            , "ioToSome = " <> x ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))+      chosen <- pickActionWithTitle "replace _toException with E.toException" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "E.toException" @=? modifiedCode+  , testSession "filling infix type hole uses prefix notation" $ do+      let mkDoc x = T.unlines+              [ "module Testing where"+              , "data A = A"+              , "foo :: A -> A -> A"+              , "foo A A = A"+              , "test :: A -> A -> A"+              , "test a1 a2 = a1 " <> x <> " a2"+              ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19))+      chosen <- pickActionWithTitle "replace _ with foo" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "`foo`" @=? modifiedCode+  , testSession "postfix hole uses postfix notation of infix operator" $ do+      let mkDoc x = T.unlines+              [ "module Testing where"+              , "test :: Int -> Int -> Int"+              , "test a1 a2 = " <> x <> " a1 a2"+              ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14))+      chosen <- pickActionWithTitle "replace _ with (+)" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "(+)" @=? modifiedCode+  , testSession "filling infix type hole uses infix operator" $ do+      let mkDoc x = T.unlines+              [ "module Testing where"+              , "test :: Int -> Int -> Int"+              , "test a1 a2 = a1 " <> x <> " a2"+              ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19))+      chosen <- pickActionWithTitle "replace _ with (+)" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "+" @=? modifiedCode+  ]++addInstanceConstraintTests :: TestTree+addInstanceConstraintTests = let+  missingConstraintSourceCode :: Maybe T.Text -> T.Text+  missingConstraintSourceCode mConstraint =+    let constraint = maybe "" (<> " => ") mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Wrap a = Wrap a"+    , ""+    , "instance " <> constraint <> "Eq (Wrap a) where"+    , "  (Wrap x) == (Wrap y) = x == y"+    ]++  incompleteConstraintSourceCode :: Maybe T.Text -> T.Text+  incompleteConstraintSourceCode mConstraint =+    let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")")  mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "instance " <> constraint <> " => Eq (Pair a b) where"+    , "  (Pair x y) == (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text+  incompleteConstraintSourceCode2 mConstraint =+    let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")")  mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Three a b c = Three a b c"+    , ""+    , "instance " <> constraint <> " => Eq (Three a b c) where"+    , "  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"+    ]++  check :: T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle originalCode expectedCode =+    checkCodeAction (T.unpack actionTitle) actionTitle originalCode expectedCode++  in testGroup "add instance constraint"+  [ check+    "Add `Eq a` to the context of the instance declaration"+    (missingConstraintSourceCode Nothing)+    (missingConstraintSourceCode $ Just "Eq a")+  , check+    "Add `Eq b` to the context of the instance declaration"+    (incompleteConstraintSourceCode Nothing)+    (incompleteConstraintSourceCode $ Just "Eq b")+  , check+    "Add `Eq c` to the context of the instance declaration"+    (incompleteConstraintSourceCode2 Nothing)+    (incompleteConstraintSourceCode2 $ Just "Eq c")+  ]++addFunctionConstraintTests :: TestTree+addFunctionConstraintTests = let+  missingConstraintSourceCode :: T.Text -> T.Text+  missingConstraintSourceCode constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "eq :: " <> constraint <> "a -> a -> Bool"+    , "eq x y = x == y"+    ]++  missingConstraintWithForAllSourceCode :: T.Text -> T.Text+  missingConstraintWithForAllSourceCode constraint =+    T.unlines+    [ "{-# LANGUAGE ExplicitForAll #-}"+    , "module Testing where"+    , ""+    , "eq :: forall a. " <> constraint <> "a -> a -> Bool"+    , "eq x y = x == y"+    ]++  incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text+  incompleteConstraintWithForAllSourceCode constraint =+    T.unlines+    [ "{-# LANGUAGE ExplicitForAll #-}"+    , "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode :: T.Text -> T.Text+  incompleteConstraintSourceCode constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode2 :: T.Text -> T.Text+  incompleteConstraintSourceCode2 constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Three a b c = Three a b c"+    , ""+    , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"+    , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"+    ]++  incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text+  incompleteConstraintSourceCodeWithExtraCharsInContext constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text+  incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint =+    T.unlines+    [ "module Testing where"+    , "data Pair a b = Pair a b"+    , "eq "+    , "    :: (" <> constraint <> ")"+    , "    => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  missingMonadConstraint constraint = T.unlines+    [ "module Testing where"+    , "f :: " <> constraint <> "m ()"+    , "f = do "+    , "  return ()"+    ]++  in testGroup "add function constraint"+  [ checkCodeAction+    "no preexisting constraint"+    "Add `Eq a` to the context of the type signature for `eq`"+    (missingConstraintSourceCode "")+    (missingConstraintSourceCode "Eq a => ")+  , checkCodeAction+    "no preexisting constraint, with forall"+    "Add `Eq a` to the context of the type signature for `eq`"+    (missingConstraintWithForAllSourceCode "")+    (missingConstraintWithForAllSourceCode "Eq a => ")+  , checkCodeAction+    "preexisting constraint, no parenthesis"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCode "Eq a")+    (incompleteConstraintSourceCode "(Eq a, Eq b)")+  , checkCodeAction+    "preexisting constraints in parenthesis"+    "Add `Eq c` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCode2 "(Eq a, Eq b)")+    (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)")+  , checkCodeAction+    "preexisting constraints with forall"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintWithForAllSourceCode "Eq a")+    (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)")+  , checkCodeAction+    "preexisting constraint, with extra spaces in context"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a")+    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b")+  , checkCodeAction+    "preexisting constraint, with newlines in type signature"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a")+    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b")+  , checkCodeAction+    "missing Monad constraint"+    "Add `Monad m` to the context of the type signature for `f`"+    (missingMonadConstraint "")+    (missingMonadConstraint "Monad m => ")+  ]++checkCodeAction :: TestName -> T.Text -> T.Text -> T.Text -> TestTree+checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do+  doc <- createDoc "Testing.hs" "haskell" originalCode+  _ <- waitForDiagnostics+  actionsOrCommands <- getAllCodeActions doc+  chosenAction <- pickActionWithTitle actionTitle actionsOrCommands+  executeCodeAction chosenAction+  modifiedCode <- documentContents doc+  liftIO $ expectedCode @=? modifiedCode++addImplicitParamsConstraintTests :: TestTree+addImplicitParamsConstraintTests =+  testGroup+    "add missing implicit params constraints"+    [ testGroup+        "introduced"+        [ let ex ctxtA = exampleCode "?a" ctxtA ""+           in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"),+          let ex ctxA = exampleCode "x where x = ?a" ctxA ""+           in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()")+        ],+      testGroup+        "inherited"+        [ let ex = exampleCode "()" "?a::()"+           in checkCodeAction+                "with preexisting context"+                "Add `?a::()` to the context of the type signature for `fCaller`"+                (ex "Eq ()")+                (ex "Eq (), ?a::()"),+          let ex = exampleCode "()" "?a::()"+           in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()")+        ]+    ]+  where+    mkContext ""       = ""+    mkContext contents = "(" <> contents <> ") => "++    exampleCode bodyBase contextBase contextCaller =+      T.unlines+        [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}",+          "module Testing where",+          "fBase :: " <> mkContext contextBase <> "()",+          "fBase = " <> bodyBase,+          "fCaller :: " <> mkContext contextCaller <> "()",+          "fCaller = fBase"+        ]++removeRedundantConstraintsTests :: TestTree+removeRedundantConstraintsTests = let+  header =+    [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+    , "module Testing where"+    , ""+    ]++  headerExt :: [T.Text] -> [T.Text]+  headerExt exts =+    redunt : extTxt ++ ["module Testing where"]+    where+      redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}"+      extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts++  redundantConstraintsCode :: Maybe T.Text -> T.Text+  redundantConstraintsCode mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "foo :: " <> constraint <> "a -> a"+        , "foo = id"+        ]++  redundantMixedConstraintsCode :: Maybe T.Text -> T.Text+  redundantMixedConstraintsCode mConstraint =+    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint+      in T.unlines $ header <>+        [ "foo :: " <> constraint <> " => a -> Bool"+        , "foo x = x == 1"+        ]++  typeSignatureSpaces :: Maybe T.Text -> T.Text+  typeSignatureSpaces mConstraint =+    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint+      in T.unlines $ header <>+        [ "foo ::  " <> constraint <> " => a -> Bool"+        , "foo x = x == 1"+        ]++  redundantConstraintsForall :: Maybe T.Text -> T.Text+  redundantConstraintsForall mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ headerExt ["RankNTypes"] <>+        [ "foo :: forall a. " <> constraint <> "a -> a"+        , "foo = id"+        ]++  typeSignatureDo :: Maybe T.Text -> T.Text+  typeSignatureDo mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "f :: Int -> IO ()"+        , "f n = do"+        , "  let foo :: " <> constraint <> "a -> IO ()"+        , "      foo _ = return ()"+        , "  r n"+        ]++  typeSignatureNested :: Maybe T.Text -> T.Text+  typeSignatureNested mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "f :: Int -> ()"+        , "f = g"+        , "  where"+        , "    g :: " <> constraint <> "a -> ()"+        , "    g _ = ()"+        ]++  typeSignatureNested' :: Maybe T.Text -> T.Text+  typeSignatureNested' mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "f :: Int -> ()"+        , "f ="+        , "  let"+        , "    g :: Int -> ()"+        , "    g = h"+        , "      where"+        , "        h :: " <> constraint <> "a -> ()"+        , "        h _ = ()"+        , "  in g"+        ]++  typeSignatureNested'' :: Maybe T.Text -> T.Text+  typeSignatureNested'' mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "f :: Int -> ()"+        , "f = g"+        , "  where"+        , "    g :: Int -> ()"+        , "    g = "+        , "      let"+        , "        h :: " <> constraint <> "a -> ()"+        , "        h _ = ()"+        , "      in h"+        ]++  typeSignatureLined1 = T.unlines $ header <>+    [ "foo :: Eq a =>"+    , "  a -> Bool"+    , "foo _ = True"+    ]++  typeSignatureLined2 = T.unlines $ header <>+    [ "foo :: (Eq a, Show a)"+    , "  => a -> Bool"+    , "foo _ = True"+    ]++  typeSignatureOneLine = T.unlines $ header <>+    [ "foo :: a -> Bool"+    , "foo _ = True"+    ]++  typeSignatureLined3 = T.unlines $ header <>+    [ "foo :: ( Eq a"+    , "       , Show a"+    , "       )"+    , "    => a -> Bool"+    , "foo x = x == x"+    ]++  typeSignatureLined3' = T.unlines $ header <>+    [ "foo :: ( Eq a"+    , "       )"+    , "    => a -> Bool"+    , "foo x = x == x"+    ]+++  check :: T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle originalCode expectedCode =+    checkCodeAction (T.unpack actionTitle) actionTitle originalCode expectedCode++  in testGroup "remove redundant function constraints"+  [ check+    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"+    (redundantConstraintsCode $ Just "Eq a")+    (redundantConstraintsCode Nothing)+  , check+    "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`"+    (redundantConstraintsCode $ Just "(Eq a, Monoid a)")+    (redundantConstraintsCode Nothing)+  , check+    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"+    (redundantMixedConstraintsCode $ Just "Monoid a, Show a")+    (redundantMixedConstraintsCode Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `g`"+    (typeSignatureNested $ Just "Eq a")+    (typeSignatureNested Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"+    (typeSignatureNested' $ Just "Eq a")+    (typeSignatureNested' Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"+    (typeSignatureNested'' $ Just "Eq a")+    (typeSignatureNested'' Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"+    (redundantConstraintsForall $ Just "Eq a")+    (redundantConstraintsForall Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"+    (typeSignatureDo $ Just "Eq a")+    (typeSignatureDo Nothing)+  , check+    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"+    (typeSignatureSpaces $ Just "Monoid a, Show a")+    (typeSignatureSpaces Nothing)+  , check+    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"+    typeSignatureLined1+    typeSignatureOneLine+  , check+    "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`"+    typeSignatureLined2+    typeSignatureOneLine+  , check+    "Remove redundant constraint `Show a` from the context of the type signature for `foo`"+    typeSignatureLined3+    typeSignatureLined3'+  ]++addSigActionTests :: TestTree+addSigActionTests = let+  header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"+           , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}"+           , "module Sigs where"+           , "data T1 a where"+           , "  MkT1 :: (Show b) => a -> b -> T1 a"+           ]+  before def     = T.unlines $ header ++ [def]+  after' def sig = T.unlines $ header ++ [sig, def]++  def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do+    let originalCode = before def+    let expectedCode = after' def sig+    doc <- createDoc "Sigs.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))+    chosenAction <- pickActionWithTitle ("add signature: " <> sig) actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "add signature"+    [ "abc = True"              >:: "abc :: Bool"+    , "foo a b = a + b"         >:: "foo :: Num a => a -> a -> a"+    , "bar a b = show $ a + b"  >:: "bar :: (Show a, Num a) => a -> a -> String"+    , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"+    , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"+    , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"+    , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"+    , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a"+    , "pattern Some a <- Just a\n  where Some a = Just a" >:: "pattern Some :: a -> Maybe a"+    , "pattern Some a <- Just !a\n  where Some !a = Just a" >:: "pattern Some :: a -> Maybe a"+    , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"+    , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)"+    , "pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"+    , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+    , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+    , "pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+    ]++exportUnusedTests :: TestTree+exportUnusedTests = testGroup "export unused actions"+  [ testGroup "don't want suggestion" -- in this test group we check that no code actions are created+    [ testSession "implicit exports" $ templateNoAction+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# OPTIONS_GHC -Wmissing-signatures #-}"+      , "module A where"+      , "foo = id"+      ]+      (R 3 0 3 3)+      "Export ‘foo’"+    , testSession "not top-level" $ templateNoAction+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (foo,bar) where"+      , "foo = ()"+      , "  where bar = ()"+      , "bar = ()"+      ]+      (R 2 0 2 11)+      "Export ‘bar’"+    , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $+      testSession "type is exported but not the constructor of same name" $ templateNoAction+        [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+        , "module A (Foo) where"+        , "data Foo = Foo"+        ]+        (R 2 0 2 8)+        "Export ‘Foo’"+    , testSession "unused data field" $ templateNoAction+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (Foo(Foo)) where"+      , "data Foo = Foo {foo :: ()}"+      ]+      (R 2 0 2 20)+      "Export ‘foo’"+    ]+  , testGroup "want suggestion"+    [ testSession "empty exports" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A ("+      , ") where"+      , "foo = id"+      ]+      (R 3 0 3 3)+      "Export ‘foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A ("+      , "foo) where"+      , "foo = id"+      ]+    , testSession "single line explicit exports" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (foo) where"+      , "foo = id"+      , "bar = foo"+      ]+      (R 3 0 3 3)+      "Export ‘bar’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (foo, bar) where"+      , "foo = id"+      , "bar = foo"+      ]+    , testSession "multi line explicit exports" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ("+      , "    foo) where"+      , "foo = id"+      , "bar = foo"+      ]+      (R 5 0 5 3)+      "Export ‘bar’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ("+      , "    foo, bar) where"+      , "foo = id"+      , "bar = foo"+      ]+    , testSession "export list ends in comma" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  (foo,"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      ]+      (R 5 0 5 3)+      "Export ‘bar’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  (foo,"+      , "  bar) where"+      , "foo = id"+      , "bar = foo"+      ]+    , testSession "style of multiple exports is preserved 1" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo"+      , "  , bar"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      ]+      (R 7 0 7 3)+      "Export ‘baz’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo"+      , "  , bar"+      , "  , baz"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      ]+    , testSession "style of multiple exports is preserved 2" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo,"+      , "    bar"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      ]+      (R 7 0 7 3)+      "Export ‘baz’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo,"+      , "    bar,"+      , "    baz"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      ]+    , testSession "style of multiple exports is preserved and selects smallest export separator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo"+      , "  , bar"+      , "  -- * For testing"+      , "  , baz"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      , "quux = bar"+      ]+      (R 10 0 10 4)+      "Export ‘quux’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A"+      , "  ( foo"+      , "  , bar"+      , "  -- * For testing"+      , "  , baz"+      , "  , quux"+      , "  ) where"+      , "foo = id"+      , "bar = foo"+      , "baz = bar"+      , "quux = bar"+      ]+    , testSession "unused pattern synonym" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE PatternSynonyms #-}"+      , "module A () where"+      , "pattern Foo a <- (a, _)"+      ]+      (R 3 0 3 10)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE PatternSynonyms #-}"+      , "module A (pattern Foo) where"+      , "pattern Foo a <- (a, _)"+      ]+    , testSession "unused data type" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "data Foo = Foo"+      ]+      (R 2 0 2 7)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (Foo(..)) where"+      , "data Foo = Foo"+      ]+    , testSession "unused newtype" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "newtype Foo = Foo ()"+      ]+      (R 2 0 2 10)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (Foo(..)) where"+      , "newtype Foo = Foo ()"+      ]+    , testSession "unused type synonym" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "type Foo = ()"+      ]+      (R 2 0 2 7)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (Foo) where"+      , "type Foo = ()"+      ]+    , testSession "unused type family" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeFamilies #-}"+      , "module A () where"+      , "type family Foo p"+      ]+      (R 3 0 3 15)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeFamilies #-}"+      , "module A (Foo) where"+      , "type family Foo p"+      ]+    , testSession "unused typeclass" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "class Foo a"+      ]+      (R 2 0 2 8)+      "Export ‘Foo’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (Foo(..)) where"+      , "class Foo a"+      ]+    , testSession "infix" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "a `f` b = ()"+      ]+      (R 2 0 2 11)+      "Export ‘f’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A (f) where"+      , "a `f` b = ()"+      ]+    , testSession "function operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A () where"+      , "(<|) = ($)"+      ]+      (R 2 0 2 9)+      "Export ‘<|’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "module A ((<|)) where"+      , "(<|) = ($)"+      ]+    , testSession "type synonym operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A () where"+      , "type (:<) = ()"+      ]+      (R 3 0 3 13)+      "Export ‘:<’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A ((:<)) where"+      , "type (:<) = ()"+      ]+    , testSession "type family operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeFamilies #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A () where"+      , "type family (:<)"+      ]+      (R 4 0 4 15)+      "Export ‘:<’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeFamilies #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A (type (:<)) where"+      , "type family (:<)"+      ]+    , testSession "typeclass operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A () where"+      , "class (:<) a"+      ]+      (R 3 0 3 11)+      "Export ‘:<’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A (type (:<)(..)) where"+      , "class (:<) a"+      ]+    , testSession "newtype operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A () where"+      , "newtype (:<) = Foo ()"+      ]+      (R 3 0 3 20)+      "Export ‘:<’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A (type (:<)(..)) where"+      , "newtype (:<) = Foo ()"+      ]+    , testSession "data type operator" $ template+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A () where"+      , "data (:<) = Foo ()"+      ]+      (R 3 0 3 17)+      "Export ‘:<’"+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+      , "{-# LANGUAGE TypeOperators #-}"+      , "module A (type (:<)(..)) where"+      , "data (:<) = Foo ()"+      ]+    ]+  ]+  where+    template origLines range actionTitle expectedLines =+      exportTemplate (Just range) origLines actionTitle (Just expectedLines)+    templateNoAction origLines range actionTitle =+      exportTemplate (Just range) origLines actionTitle Nothing++exportTemplate :: Maybe Range -> [T.Text] -> T.Text -> Maybe [T.Text] -> Session ()+exportTemplate mRange initialLines expectedAction expectedLines = do+  doc <- createDoc "A.hs" "haskell" $ T.unlines initialLines+  _ <- waitForDiagnostics+  actions <- case mRange of+    Nothing    -> getAllCodeActions doc+    Just range -> getCodeActions doc range+  case expectedLines of+    Just content -> do+      action <- pickActionWithTitle expectedAction actions+      executeCodeAction action+      contentAfterAction <- documentContents doc+      liftIO $ T.unlines content @=? contentAfterAction+    Nothing ->+      liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= []++removeExportTests :: TestTree+removeExportTests = testGroup "remove export actions"+    [ testSession "single export" $ template+        [ "module A (  a   ) where"+        , "b :: ()"+        , "b = ()"+        ]+        "Remove ‘a’ from export"+        [ "module A (     ) where"+        , "b :: ()"+        , "b = ()"+        ]+    , testSession "ending comma" $ template+        [ "module A (  a,   ) where"+        , "b :: ()"+        , "b = ()"+        ]+        "Remove ‘a’ from export"+        [ "module A (  ) where"+        , "b :: ()"+        , "b = ()"+        ]+    , testSession "multiple exports" $ template+        [ "module A (a  ,   c,    b ) where"+        , "a, c :: ()"+        , "a = ()"+        , "c = ()"+        ]+        "Remove ‘b’ from export"+        [ "module A (a  ,   c ) where"+        , "a, c :: ()"+        , "a = ()"+        , "c = ()"+        ]+    , testSession "not in scope constructor" $ template+        [ "module A (A (X,Y,Z,(:<)), ab) where"+        , "data A = X Int | Y | (:<) Int"+        , "ab :: ()"+        , "ab = ()"+        ]+        "Remove ‘Z’ from export"+        [ "module A (A (X,Y,(:<)), ab) where"+        , "data A = X Int | Y | (:<) Int"+        , "ab :: ()"+        , "ab = ()"+        ]+    , testSession "multiline export" $ template+        [ "module A (a"+        , " ,  b"+        , " , (:*:)"+        , " , ) where"+        , "a,b :: ()"+        , "a = ()"+        , "b = ()"+        ]+        "Remove ‘:*:’ from export"+        [ "module A (a"+        , " ,  b"+        , " "+        , " , ) where"+        , "a,b :: ()"+        , "a = ()"+        , "b = ()"+        ]+    , testSession "qualified re-export" $ template+        [ "module A (M.x,a) where"+        , "import qualified Data.List as M"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove ‘M.x’ from export"+        [ "module A (a) where"+        , "import qualified Data.List as M"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "qualified re-export ending in '.'" $ template+        [ "module A ((M.@.),a) where"+        , "import qualified Data.List as M"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove ‘M.@.’ from export"+        [ "module A (a) where"+        , "import qualified Data.List as M"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "export module" $ template+        [ "module A (module B) where"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove ‘module B’ from export"+        [ "module A () where"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "dodgy export" $ template+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A (A (..)) where"+        , "data X = X"+        , "type A = X"+        ]+        "Remove ‘A(..)’ from export"+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A () where"+        , "data X = X"+        , "type A = X"+        ]+    , testSession "dodgy export" $ template+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A (A (..)) where"+        , "data X = X"+        , "type A = X"+        ]+        "Remove ‘A(..)’ from export"+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A () where"+        , "data X = X"+        , "type A = X"+        ]+    , testSession "duplicate module export" $ template+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A (module L,module L) where"+        , "import Data.List as L"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove ‘Module L’ from export"+        [ "{-# OPTIONS_GHC -Wall #-}"+        , "module A (module L) where"+        , "import Data.List as L"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "remove all exports single" $ template+        [ "module A (x) where"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove all redundant exports"+        [ "module A () where"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "remove all exports two" $ template+        [ "module A (x,y) where"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove all redundant exports"+        [ "module A () where"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "remove all exports three" $ template+        [ "module A (a,x,y) where"+        , "a :: ()"+        , "a = ()"+        ]+        "Remove all redundant exports"+        [ "module A (a) where"+        , "a :: ()"+        , "a = ()"+        ]+    , testSession "remove all exports composite" $ template+        [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where"+        , "data A = X {getV :: Int} | Y {getV :: Int}"+        , "data B = B"+        , "a,b :: ()"+        , "a = ()"+        , "b = ()"+        ]+        "Remove all redundant exports"+        [ "module A (b, a, A(X, Y,getV), B(B)) where"+        , "data A = X {getV :: Int} | Y {getV :: Int}"+        , "data B = B"+        , "a,b :: ()"+        , "a = ()"+        , "b = ()"+        ]+    ]+  where+    template origLines actionTitle expectedLines =+      exportTemplate Nothing origLines actionTitle (Just expectedLines)+++codeActionHelperFunctionTests :: TestTree+codeActionHelperFunctionTests = testGroup "code action helpers"+    [ extendImportTestsRegEx+    ]++extendImportTestsRegEx :: TestTree+extendImportTestsRegEx = testGroup "regex parsing"+    [ testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing+    , testCase "parse malformed import list" $ template+                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"+                  Nothing+    , testCase "parse multiple imports" $ template+                 (if ghcVersion >= GHC98+                 then "\n\8226 Add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (at app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (at app/testlsp.hs:8:1-29)"+                 else "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"+                 )+                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])+    ]+    where+        template message expected = do+            liftIO $ expected @=? matchRegExMultipleImports message++pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> Session CodeAction+pickActionWithTitle title actions =+  case matches of+    [] -> liftIO . assertFailure $ "CodeAction with title " <> show title <> " not found in " <> show titles+    a:_ -> pure a+  where+    titles =+        [ actionTitle+        | InR CodeAction { _title = actionTitle } <- actions+        ]+    matches =+        [ action+        | InR action@CodeAction { _title = actionTitle } <- actions+        , title == actionTitle+        ]++assertNoActionWithTitle :: T.Text -> [Command |? CodeAction] -> Session ()+assertNoActionWithTitle title actions =+  liftIO $ assertBool+      ("Unexpected code action " <> show title <> " in " <> show titles)+      (title `notElem` titles)+  where+    titles =+        [ actionTitle+        | InR CodeAction { _title = actionTitle } <- actions+        ]++assertActionWithTitle :: [Command |? CodeAction] -> T.Text -> Session ()+assertActionWithTitle actions title =+  liftIO $ assertBool+    ("CodeAction with title " <> show title <>" not found in " <> show titles)+    (title `elem` titles)+  where+    titles =+        [ actionTitle+        | InR CodeAction { _title = actionTitle } <- actions+        ]++testSession :: TestName -> Session () -> TestTree+testSession name = testCase name . run++testSessionWithExtraFiles :: HasCallStack => FilePath -> TestName -> (FilePath -> Session ()) -> TestTree+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix++runWithExtraFiles :: HasCallStack => FilePath -> (FilePath -> Session a) -> IO a+runWithExtraFiles prefix s = withTempDir $ \dir -> do+  copyTestDataFiles dir prefix+  runInDir dir (s dir)++copyTestDataFiles :: HasCallStack => FilePath -> FilePath -> IO ()+copyTestDataFiles dir prefix = do+  -- Copy all the test data files to the temporary workspace+  testDataFiles <- getDirectoryFilesIO ("plugins/hls-refactor-plugin/test/data" </> prefix) ["//*"]+  for_ testDataFiles $ \f -> do+    createDirectoryIfMissing True $ dir </> takeDirectory f+    copyFile ("plugins/hls-refactor-plugin/test/data" </> prefix </> f) (dir </> f)++run :: Session a -> IO a+run s = run' (const s)++run' :: (FilePath -> Session a) -> IO a+run' s = withTempDir $ \dir -> runInDir dir (s dir)++runInDir :: FilePath -> Session a -> IO a+runInDir dir act = do+  plugin <- refactorPlugin+  runSessionWithServer' plugin def def lspTestCaps dir act++lspTestCaps :: ClientCapabilities+lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }++pattern R :: UInt -> UInt -> UInt -> UInt -> Range+pattern R x y x' y' = Range (Position x y) (Position x' y')++-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path+-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or+-- @/var@+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir f = System.IO.Extra.withTempDir $ \dir ->+  canonicalizePath dir >>= f++brokenForGHC94 :: String -> TestTree -> TestTree+brokenForGHC94 = knownBrokenForGhcVersions [GHC94]++brokenForGHC92 :: String -> TestTree -> TestTree+brokenForGHC92 = knownBrokenForGhcVersions [GHC92]
+ plugins/hls-refactor-plugin/test/Test/AddArgument.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE OverloadedStrings     #-}++module Test.AddArgument (tests) where++import qualified Data.Text                         as T+import           Development.IDE.Types.Location+import           Language.LSP.Protocol.Types       hiding+                                                   (SemanticTokensEdit (_start),+                                                    mkRange)+import           Language.LSP.Test+import           Test.Tasty+import           Test.Tasty.HUnit+++import           Test.Hls+import qualified Test.Hls.FileSystem               as FS++import qualified Development.IDE.Plugin.CodeAction as Refactor+import           System.FilePath                   ((<.>))++tests :: TestTree+tests =+  testGroup+    "add argument"+    [ mkGoldenAddArgTest' "Hole" (r 0 0 0 50) "_new_def",+      mkGoldenAddArgTest "NoTypeSuggestion" (r 0 0 0 50),+      mkGoldenAddArgTest "MultipleDeclAlts" (r 0 0 0 50),+      mkGoldenAddArgTest "AddArgWithSig" (r 1 0 1 50),+      mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50),+      mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50),+      mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50),+      mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50),+      mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50),+      mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50),+      mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50),+      mkGoldenAddArgTest "MultiSigFirst" (r 2 0 2 50),+      mkGoldenAddArgTest "MultiSigLast" (r 2 0 2 50),+      mkGoldenAddArgTest "MultiSigMiddle" (r 2 0 2 50)+    ]+  where+    r x y x' y' = Range (Position x y) (Position x' y')++mkGoldenAddArgTest :: FilePath -> Range -> TestTree+mkGoldenAddArgTest testFileName range = mkGoldenAddArgTest' testFileName range "new_def"++-- Make a golden test for the add argument action. Given varName is the name of the variable not yet defined.+mkGoldenAddArgTest' :: FilePath -> Range -> T.Text -> TestTree+mkGoldenAddArgTest' testFileName range varName = do+    let action docB = do+          _ <- waitForDiagnostics+          let matchAction a = case a of+                InR CodeAction {_title = t} -> "Add" `T.isPrefixOf` t+                _                           -> False+          InR action@CodeAction {_title = actionTitle} : _ <-+            filter matchAction <$> getCodeActions docB range+          liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function")+          executeCodeAction action+    goldenWithHaskellDocInTmpDir+      def+      (mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings")+      (testFileName <> " (golden)")+      (FS.mkVirtualFileTree "plugins/hls-refactor-plugin/test/data/golden/add-arg" (FS.directProject $ testFileName <.> "hs"))+      testFileName+      "expected"+      "hs"+      action
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.expected.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> _ -> Int+foo True new_def =+  let bar = new_def+  in bar++foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> Int+foo True =+  let bar = new_def+  in bar++foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.expected.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> _ -> Int+foo True new_def = bar+  where+    bar = new_def++foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> Int+foo True = bar+  where+    bar = new_def++foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs view
@@ -0,0 +1,6 @@+foo -- c1+  -- | c2+  {- c3 -} True new_def -- c4+  = new_def++foo False new_def = False
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs view
@@ -0,0 +1,6 @@+foo -- c1+  -- | c2+  {- c3 -} True -- c4+  = new_def++foo False = False
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.expected.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> _ -> () -> Int+foo True new_def = \() -> new_def [True]++foo False new_def = const 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> () -> Int+foo True = \() -> new_def [True]++foo False = const 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.expected.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> _ -> Int+foo True new_def = new_def [True]++foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> Int+foo True = new_def [True]++foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs view
@@ -0,0 +1,11 @@+foo ::+  -- c1+  Bool -- c2+  -- c3+  -> -- c4+  -- | c5+  () -- c6+  -> _ -> Int+foo True () new_def = new_def [True]++foo False () new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.hs view
@@ -0,0 +1,11 @@+foo ::+  -- c1+  Bool -- c2+  -- c3+  -> -- c4+  -- | c5+  () -- c6+  -> Int+foo True () = new_def [True]++foo False () = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn+foo True new_def = new_def [True]++foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn+foo True = new_def [True]++foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn -> () -> _ -> Int+foo True () new_def = new_def [True]++foo False () new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn -> () -> Int+foo True () = new_def [True]++foo False () = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs view
@@ -0,0 +1,1 @@+foo _new_def = _new_def
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs view
@@ -0,0 +1,1 @@+foo = _new_def
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.expected.hs view
@@ -0,0 +1,6 @@+bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.hs view
@@ -0,0 +1,5 @@+foo, bar :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.expected.hs view
@@ -0,0 +1,7 @@+baz, bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1+baz = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.hs view
@@ -0,0 +1,6 @@+baz, bar, foo :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1+baz = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.expected.hs view
@@ -0,0 +1,7 @@+baz, bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1+baz = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.hs view
@@ -0,0 +1,6 @@+baz, foo, bar :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1+baz = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs view
@@ -0,0 +1,2 @@+foo True new_def = new_def+foo False new_def = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs view
@@ -0,0 +1,2 @@+foo True = new_def+foo False = 1
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs view
@@ -0,0 +1,1 @@+foo new_def = new_def
+ plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs view
@@ -0,0 +1,1 @@+foo = new_def
+ plugins/hls-refactor-plugin/test/data/hiding/AVec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeOperators #-}+module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where++import Prelude hiding ((++))++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined++data (@@@) a b++fromList :: [a] -> Vec a+fromList = undefined++cons :: a -> Vec a -> Vec a+cons = undefined++snoc :: Vec a -> a -> Vec a+snoc = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/BVec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeOperators #-}+module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where++import Prelude hiding ((++))++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined++data (@@@) a b++fromList :: [a] -> Vec a+fromList = undefined++cons :: a -> Vec a -> Vec a+cons = undefined++snoc :: Vec a -> a -> Vec a+snoc = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/CVec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeOperators #-}+module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where++import Prelude hiding ((++))++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined++data (@@@) a b++fromList :: [a] -> Vec a+fromList = undefined++cons :: a -> Vec a -> Vec a+cons = undefined++snoc :: Vec a -> a -> Vec a+snoc = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/DVec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeOperators #-}+module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where++import Prelude hiding ((++))++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined++data (@@@) a b++fromList :: [a] -> Vec a+fromList = undefined++cons :: a -> Vec a -> Vec a+cons = undefined++snoc :: Vec a -> a -> Vec a+snoc = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/EVec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeOperators #-}+module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where++import Prelude hiding ((++))++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined++data (@@@) a b++fromList :: [a] -> Vec a+fromList = undefined++cons :: a -> Vec a -> Vec a+cons = undefined++snoc :: Vec a -> a -> Vec a+snoc = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/FVec.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DuplicateRecordFields #-}++module FVec (RecA(..), RecB(..)) where++data Vec a++newtype RecA a = RecA { fromList :: [a] -> Vec a }++newtype RecB a = RecB { fromList :: [a] -> Vec a }
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs view
@@ -0,0 +1,12 @@+module HideFunction where++import AVec (fromList)+import BVec (fromList)+import CVec hiding ((++), cons)+import DVec hiding ((++), cons, snoc)+import EVec as E+import Prelude hiding ((++))++theFun = fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec (fromList)+import BVec (fromList)+import CVec hiding ((++), cons)+import DVec hiding ((++), cons, snoc)+import EVec as E hiding ((++))++theFun = fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec (fromList)+import BVec ( (++))+import CVec hiding (fromList, cons)+import DVec hiding (fromList, cons, snoc)+import EVec as E hiding (fromList)++theFun = fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec ()+import BVec (fromList, (++))+import CVec hiding (fromList, cons)+import DVec hiding (fromList, cons, snoc)+import EVec as E hiding (fromList)++theFun = fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec (fromList)+import BVec (fromList, (++))+import CVec hiding (cons)+import DVec hiding (cons, snoc)+import EVec as E++theFun = fromList++theOp = (Prelude.++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec (fromList)+import BVec (fromList, (++))+import CVec hiding (cons)+import DVec hiding (cons, snoc)+import EVec as E++theFun = E.fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs view
@@ -0,0 +1,11 @@+module HideFunction where++import AVec (fromList)+import BVec (fromList, (++))+import CVec hiding (cons)+import DVec hiding (cons, snoc)+import EVec as E++theFun = fromList++theOp = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs view
@@ -0,0 +1,14 @@+module HideFunctionWithoutLocal where++import AVec (fromList)+import BVec (fromList)+import CVec hiding ((++), cons)+import DVec hiding ((++), cons, snoc)+import EVec as E hiding ((++))+import Prelude hiding ((++))++theOp = (++)++data Vec a++(++) = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs view
@@ -0,0 +1,13 @@+module HideFunctionWithoutLocal where++import AVec (fromList)+import BVec (fromList, (++))+import CVec hiding (cons)+import DVec hiding (cons, snoc)+import EVec as E++theOp = (++)++data Vec a++(++) = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs view
@@ -0,0 +1,5 @@+module HidePreludeIndented where++   import AVec+   import Prelude hiding ((++))+   op = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs view
@@ -0,0 +1,4 @@+module HidePreludeIndented where++   import AVec+   op = (++)
+ plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs view
@@ -0,0 +1,9 @@+module HidePreludeLocalInfix where+import Prelude hiding ((++))++infixed xs ys = xs ++ ys++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs view
@@ -0,0 +1,8 @@+module HidePreludeLocalInfix where++infixed xs ys = xs ++ ys++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs view
@@ -0,0 +1,10 @@+module HideQualifyDuplicateRecordFields where++import AVec+import BVec+import CVec+import DVec+import EVec+import FVec++theFun = AVec.fromList
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs view
@@ -0,0 +1,10 @@+module HideQualifyDuplicateRecordFields where++import AVec+import BVec+import CVec+import DVec+import EVec+import FVec++theFun = fromList
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs view
@@ -0,0 +1,5 @@+module HideQualifyDuplicateRecordFieldsSelf where++import FVec++x = fromList
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs view
@@ -0,0 +1,5 @@+module HideQualifyInfix where++import AVec++infixed xs ys = xs Prelude.++ ys
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs view
@@ -0,0 +1,5 @@+module HideQualifyInfix where++import AVec++infixed xs ys = xs ++ ys
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs view
@@ -0,0 +1,5 @@+module HideQualifySectionLeft where++import AVec++sectLeft xs = (Prelude.++ xs)
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs view
@@ -0,0 +1,5 @@+module HideQualifySectionLeft where++import AVec++sectLeft xs = (++ xs)
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs view
@@ -0,0 +1,5 @@+module HideQualifySectionRight where++import AVec++sectLeft xs = (xs Prelude.++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs view
@@ -0,0 +1,5 @@+module HideQualifySectionRight where++import AVec++sectLeft xs = (xs ++)
+ plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs view
@@ -0,0 +1,9 @@+module HideType where++import AVec (Vec, fromList)+import BVec (fromList, (++))+import CVec hiding (Vec, cons)+import DVec hiding (Vec, cons, snoc)+import EVec as E hiding (Vec)++type TheType = Vec
+ plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs view
@@ -0,0 +1,9 @@+module HideType where++import AVec ( fromList)+import BVec (fromList, (++))+import CVec hiding (Vec, cons)+import DVec hiding (Vec, cons, snoc)+import EVec as E++type TheType = Vec
+ plugins/hls-refactor-plugin/test/data/hiding/HideType.hs view
@@ -0,0 +1,9 @@+module HideType where++import AVec (Vec, fromList)+import BVec (fromList, (++))+import CVec hiding (cons)+import DVec hiding (cons, snoc)+import EVec as E++type TheType = Vec
+ plugins/hls-refactor-plugin/test/data/hiding/hie.yaml view
@@ -0,0 +1,10 @@+cradle:+    direct:+        arguments:+        - -Wall+        - AVec.hs+        - BVec.hs+        - CVec.hs+        - DVec.hs+        - EVec.hs+        - FVec.hs
+ plugins/hls-refactor-plugin/test/data/hover/Bar.hs view
@@ -0,0 +1,4 @@+module Bar (Bar(..)) where++-- | Bar Haddock+data Bar = Bar
+ plugins/hls-refactor-plugin/test/data/hover/Foo.hs view
@@ -0,0 +1,6 @@+module Foo (Bar, foo) where++import Bar++-- | foo Haddock+foo = Bar
+ plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{- HLINT ignore -}+module GotoHover ( module GotoHover) where+import Data.Text (Text, pack)+import Foo (Bar, foo)+++data TypeConstructor = DataConstructor+  { fff :: Text+  , ggg :: Int }+aaa :: TypeConstructor+aaa = DataConstructor+  { fff = "dfgy"+  , ggg = 832+  }+bbb :: TypeConstructor+bbb = DataConstructor "mjgp" 2994+ccc :: (Text, Int)+ccc = (fff bbb, ggg aaa)+ddd :: Num a => a -> a -> a+ddd vv ww = vv +! ww+a +! b = a - b+hhh (Just a) (><) = a >< a+iii a b = a `b` a+jjj s = pack $ s <> s+class MyClass a where+  method :: a -> Int+instance MyClass Int where+  method = succ+kkk :: MyClass a => Int -> a -> Int+kkk n c = n + method c++doBind :: Maybe ()+doBind = do unwrapped <- Just ()+            return unwrapped++listCompBind :: [Char]+listCompBind = [ succ c | c <- "ptfx" ]++multipleClause :: Bool -> Char+multipleClause True  =    't'+multipleClause False = 'f'++-- | Recognizable docs: kpqz+documented :: Monad m => Either Int (m a)+documented = Left 7518++listOfInt = [ 8391 :: Int, 6268 ]++outer :: Bool+outer = undefined inner where++  inner :: Char+  inner = undefined++imported :: Bar+imported = foo++aa2 :: Bool+aa2 = $(id [| True |])++hole :: Int+hole = _++hole2 :: a -> Maybe a+hole2 = _
+ plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-}++module RecordDotSyntax ( module RecordDotSyntax) where++import qualified Data.Maybe as M++data MyRecord = MyRecord+  { a :: String+  , b :: Integer+  , c :: MyChild+  } deriving (Eq, Show)++newtype MyChild = MyChild+  { z :: String+  } deriving (Eq, Show)++x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } }+y = x.a ++ show x.b ++ x.c.z
+ plugins/hls-refactor-plugin/test/data/hover/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}}
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs view
@@ -0,0 +1,12 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- | Another comment+data SomethingElse = SomethingElse++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where++-- | Another comment+data SomethingElse = SomethingElse++-- | Some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++{- Some comment -}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++{- Some comment -}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++data Something = Something++-- | some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++data Something = Something++-- | some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs view
@@ -0,0 +1,14 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Monoid++{- Some multi +   line comment +-}+class Semigroup a => SomeData a++-- | a comment+instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs view
@@ -0,0 +1,13 @@+module Test+( SomeData(..)+) where++import Data.Char++{- Some multi +   line comment +-}+class Semigroup a => SomeData a++-- | a comment+instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wprepositive-qualified-module #-}+import Control.Monad qualified as Control+main :: IO ()+main = Control.when True $ putStrLn "hello"
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wprepositive-qualified-module #-}+main :: IO ()+main = Control.when True $ putStrLn "hello"
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.expected.hs view
@@ -0,0 +1,3 @@+import qualified Control.Monad as Control+main :: IO ()+main = Control.when True $ putStrLn "hello"
+ plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = Control.when True $ putStrLn "hello"
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where+import Data.Monoid++-- comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}++module Test+( SomeData(..)+) where++-- comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid++-- | comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}++-- | comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where+import Data.Char+import Data.Array+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Char+import Data.Array++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++{- Some multi +   line comment +-}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++{- Some multi +   line comment +-}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, +   OverloadedStrings #-}+{-# OPTIONS_GHC -Wall,+  -Wno-unused-imports #-}+import Data.Monoid+++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, +   OverloadedStrings #-}+{-# OPTIONS_GHC -Wall,+  -Wno-unused-imports #-}+++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs view
@@ -0,0 +1,14 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Bool+import Data.Eq+import Data.Monoid++-- | A comment+class Semigroup a => SomeData a++-- | another comment+instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs view
@@ -0,0 +1,13 @@+module Test+( SomeData(..)+) where++import Data.Char+import Data.Bool+import Data.Eq++-- | A comment+class Semigroup a => SomeData a++-- | another comment+instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+import Data.Monoid++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}++-- some comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs view
@@ -0,0 +1,11 @@+module Test+( SomeData(..)+) where+import Data.Monoid++newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs view
@@ -0,0 +1,10 @@+module Test+( SomeData(..)+) where++newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs view
@@ -0,0 +1,7 @@+module Test where+import Data.Monoid++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs view
@@ -0,0 +1,6 @@+module Test where++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs view
@@ -0,0 +1,8 @@+module Test where+import Data.Monoid++newtype Something = S { foo :: Int }++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs view
@@ -0,0 +1,7 @@+module Test where++newtype Something = S { foo :: Int }++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs view
@@ -0,0 +1,7 @@+import Data.Monoid+newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs view
@@ -0,0 +1,6 @@+newtype Something = S { foo :: Int }++-- | a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs view
@@ -0,0 +1,5 @@+import Data.Monoid+-- a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs view
@@ -0,0 +1,4 @@+-- a comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# LANGUAGE TupleSections #-}+import Data.Monoid+++++class Semigroup a => SomeData a+instance SomeData All++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# LANGUAGE TupleSections #-}+++++class Semigroup a => SomeData a+instance SomeData All++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs view
@@ -0,0 +1,8 @@+import Data.Monoid+class Semigroup a => SomeData a+instance SomeData All++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs view
@@ -0,0 +1,7 @@+class Semigroup a => SomeData a+instance SomeData All++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wall,+   OPTIONS_GHC -Wno-unrecognised-pragmas #-}+-- another comment+-- oh+{- multi line +comment+-}++{-# LANGUAGE TupleSections #-}+import Data.Monoid+{- some comment -}++-- again+class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wall,+   OPTIONS_GHC -Wno-unrecognised-pragmas #-}+-- another comment+-- oh+{- multi line +comment+-}++{-# LANGUAGE TupleSections #-}+{- some comment -}++-- again+class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wall #-}+-- another comment++{-# LANGUAGE TupleSections #-}+import Data.Monoid+{- some comment -}+++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wall #-}+-- another comment++{-# LANGUAGE TupleSections #-}+{- some comment -}+++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE TupleSections #-}+module Test+( SomeData(..)+) where+import Data.Text+import Data.Monoid+++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE TupleSections #-}+module Test+( SomeData(..)+) where+import Data.Text+++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE TupleSections #-}+module Test+( SomeData(..)+) where+import Data.Monoid+++++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE TupleSections #-}+module Test+( SomeData(..)+) where+++++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test where++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test+( SomeData(..)+) where+import Data.Monoid++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++module Test+( SomeData(..)+) where++class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+import Data.Monoid++{- | some multiline+  comment+   ... -}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+#! /usr/bin/env nix-shell+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++{- | some multiline+  comment+   ... -}+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++f :: Int -> Int +f x = x * x
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++f :: Int -> Int +f x = x * x
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs view
@@ -0,0 +1,8 @@+import Data.Monoid+class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++f :: Int -> Int +f x = x * x
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs view
@@ -0,0 +1,7 @@+class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"++f :: Int -> Int +f x = x * x
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# OPTIONS_GHC -Wall #-}++++{-# LANGUAGE TupleSections #-}+import Data.Monoid+++++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+++{-# OPTIONS_GHC -Wall #-}++++{-# LANGUAGE TupleSections #-}+++++class Semigroup a => SomeData a+instance SomeData All++#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs view
@@ -0,0 +1,9 @@+module Test+( SomeData(..)+) where+import Data.Monoid++-- no vertical bar comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs view
@@ -0,0 +1,8 @@+module Test+( SomeData(..)+) where++-- no vertical bar comment+class Semigroup a => SomeData a++instance SomeData All
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs view
@@ -0,0 +1,18 @@+module Asdf + (f+ , where') + + where+import Data.Int++++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int +g = id++where' :: Int -> Int +where' = id
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs view
@@ -0,0 +1,17 @@+module Asdf + (f+ , where') + + where++++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int +g = id++where' :: Int -> Int +where' = id
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs view
@@ -0,0 +1,20 @@+module Asdf+ (f+ , where')+-- hello+-- world++ where+import Data.Int++++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int+g = id++where' :: Int -> Int+where' = id
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs view
@@ -0,0 +1,19 @@+module Asdf+ (f+ , where')+-- hello+-- world++ where++++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int+g = id++where' :: Int -> Int+where' = id
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs view
@@ -0,0 +1,16 @@+module Asdf + + + where+import Data.Int+++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int +g = id++where' :: Int -> Int +where' = id
+ plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs view
@@ -0,0 +1,15 @@+module Asdf + + + where+++f :: Int64 -> Int64+f = id'+  where id' = id++g :: Int -> Int +g = id++where' :: Int -> Int +where' = id
+ plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Ide.Plugin.Rename (descriptor, E.Log) where++import           Compat.HieTypes+import           Control.Lens                          ((^.))+import           Control.Monad+import           Control.Monad.Except                  (ExceptT, throwError)+import           Control.Monad.IO.Class                (MonadIO, liftIO)+import           Control.Monad.Trans.Class             (lift)+import           Data.Bifunctor                        (first)+import           Data.Foldable                         (fold)+import           Data.Generics+import           Data.Hashable+import           Data.HashSet                          (HashSet)+import qualified Data.HashSet                          as HS+import           Data.List.NonEmpty                    (NonEmpty ((:|)),+                                                        groupWith)+import qualified Data.Map                              as M+import           Data.Maybe+import           Data.Mod.Word+import qualified Data.Set                              as S+import qualified Data.Text                             as T+import           Development.IDE                       (Recorder, WithPriority,+                                                        usePropertyAction)+import           Development.IDE.Core.PluginUtils+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.Core+import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.Compat.Parser+import           Development.IDE.GHC.Compat.Units+import           Development.IDE.GHC.Error+import           Development.IDE.GHC.ExactPrint+import qualified Development.IDE.GHC.ExactPrint        as E+import           Development.IDE.Plugin.CodeAction+import           Development.IDE.Spans.AtPoint+import           Development.IDE.Types.Location+import           HieDb.Query+import           Ide.Plugin.Error+import           Ide.Plugin.Properties+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens            as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Language.LSP.Server++instance Hashable (Mod a) where hash n = hash (unMod n)++descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers")+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentRename renameProvider+    , pluginConfigDescriptor = defaultConfigDescriptor+        { configCustomConfig = mkCustomConfig properties }+    }++renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename+renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do+        nfp <- getNormalizedFilePathE uri+        directOldNames <- getNamesAtPos state nfp pos+        directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames++        {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have+           indirect references through punned names. To find the transitive closure, we do a pass of+           the direct references to find the references for any punned names.+           See the `IndirectPuns` test for an example. -}+        indirectOldNames <- concat . filter ((>1) . length) <$>+            mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs+        let oldNames = filter matchesDirect indirectOldNames ++ directOldNames+            matchesDirect n = occNameFS (nameOccName n) `elem` directFS+              where+                directFS = map (occNameFS. nameOccName) directOldNames+        refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames++        -- Validate rename+        crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties+        unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames+        when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax"++        -- Perform rename+        let newName = mkTcOcc $ T.unpack newNameText+            filesRefs = collectWith locToUri refs+            getFileEdit (uri, locations) = do+              verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri)+              getSrcEdit state verTxtDocId (replaceRefs newName locations)+        fileEdits <- mapM getFileEdit filesRefs+        pure $ InL $ fold fileEdits++-- | Limit renaming across modules.+failWhenImportOrExport ::+    (MonadLsp config m) =>+    IdeState ->+    NormalizedFilePath ->+    HashSet Location ->+    [Name] ->+    ExceptT PluginError m ()+failWhenImportOrExport state nfp refLocs names = do+    pm <- runActionE "Rename.GetParsedModule" state+         (useE GetParsedModule nfp)+    let hsMod = unLoc $ pm_parsed_source pm+    case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of+        (mbModName, _) | not $ any (\n -> nameIsLocalOrFrom (replaceModName n mbModName) n) names+            -> throwError $ PluginInternalError "Renaming of an imported name is unsupported"+        (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports+            -> throwError $ PluginInternalError "Renaming of an exported name is unsupported"+        (Just _, Nothing) -> throwError $ PluginInternalError "Explicit export list required for renaming"+        _ -> pure ()++---------------------------------------------------------------------------------------------------+-- Source renaming++-- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`.+getSrcEdit ::+    (MonadLsp config m) =>+    IdeState ->+    VersionedTextDocumentIdentifier ->+    (ParsedSource -> ParsedSource) ->+    ExceptT PluginError m WorkspaceEdit+getSrcEdit state verTxtDocId updatePs = do+    ccs <- lift getClientCapabilities+    nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)+    annAst <- runActionE "Rename.GetAnnotatedParsedSource" state+        (useE GetAnnotatedParsedSource nfp)+    let ps = astA annAst+        src = T.pack $ exactPrint ps+        res = T.pack $ exactPrint (updatePs ps)+    pure $ diffText ccs (verTxtDocId, src) res IncludeDeletions++-- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name.+replaceRefs ::+    OccName ->+    HashSet Location ->+    ParsedSource ->+    ParsedSource+replaceRefs newName refs = everywhere $+    -- there has to be a better way...+    mkT (replaceLoc @AnnListItem) `extT`+    -- replaceLoc @AnnList `extT` -- not needed+    -- replaceLoc @AnnParen `extT` -- not needed+    -- replaceLoc @AnnPragma `extT` -- not needed+    -- replaceLoc @AnnContext `extT` -- not needed+    -- replaceLoc @NoEpAnns `extT` -- not needed+    replaceLoc @NameAnn+    where+        replaceLoc :: forall an. LocatedAn an RdrName -> LocatedAn an RdrName+        replaceLoc (L srcSpan oldRdrName)+            | isRef (locA srcSpan) = L srcSpan $ replace oldRdrName+        replaceLoc lOldRdrName = lOldRdrName+        replace :: RdrName -> RdrName+        replace (Qual modName _) = Qual modName newName+        replace _                = Unqual newName++        isRef :: SrcSpan -> Bool+        isRef = (`HS.member` refs) . unsafeSrcSpanToLoc++---------------------------------------------------------------------------------------------------+-- Reference finding++-- | Note: We only find exact name occurrences (i.e. type reference "depth" is 0).+refsAtName ::+    MonadIO m =>+    IdeState ->+    NormalizedFilePath ->+    Name ->+    ExceptT PluginError m [Location]+refsAtName state nfp name = do+    ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras+    ast <- handleGetHieAst state nfp+    dbRefs <- case nameModule_maybe name of+        Nothing -> pure []+        Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb ->+            findReferences+                hieDb+                True+                (nameOccName name)+                (Just $ moduleName mod)+                (Just $ moduleUnit mod)+                [fromNormalizedFilePath nfp]+            )+    pure $ nameLocs name ast ++ dbRefs++nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location]+nameLocs name (HAR _ _ rm _ _, pm) =+    concatMap (mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst))+              (M.lookup (Right name) rm)++---------------------------------------------------------------------------------------------------+-- Util++getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name]+getNamesAtPos state nfp pos = do+    (HAR{hieAst}, pm) <- handleGetHieAst state nfp+    pure $ getNamesAtPoint hieAst pos pm++handleGetHieAst ::+    MonadIO m =>+    IdeState ->+    NormalizedFilePath ->+    ExceptT PluginError m (HieAstResult, PositionMapping)+handleGetHieAst state nfp =+    fmap (first removeGenerated) $ runActionE "Rename.GetHieAst" state $ useWithStaleE GetHieAst nfp++-- | We don't want to rename in code generated by GHC as this gives false positives.+-- So we restrict the HIE file to remove all the generated code.+removeGenerated :: HieAstResult -> HieAstResult+removeGenerated HAR{..} = HAR{hieAst = go hieAst,..}+  where+    go :: HieASTs a -> HieASTs a+    go hf =+      HieASTs (fmap goAst (getAsts hf))+    goAst (Node nsi sp xs) = Node (SourcedNodeInfo $ M.restrictKeys (getSourcedNodeInfo nsi) (S.singleton SourceInfo)) sp (map goAst xs)++collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)]+collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList++locToUri :: Location -> Uri+locToUri (Location uri _) = uri++unsafeSrcSpanToLoc :: SrcSpan -> Location+unsafeSrcSpanToLoc srcSpan =+    case srcSpanToLocation srcSpan of+        Nothing       -> error "Invalid conversion from UnhelpfulSpan to Location"+        Just location -> location++locToFilePos :: Monad m => Location -> ExceptT PluginError m (NormalizedFilePath, Position)+locToFilePos (Location uri (Range pos _)) = (,pos) <$> getNormalizedFilePathE uri++replaceModName :: Name -> Maybe ModuleName -> Module+replaceModName name mbModName =+    mkModule (moduleUnit $ nameModule name) (fromMaybe (mkModuleName "Main") mbModName)++---------------------------------------------------------------------------------------------------+-- Config++properties :: Properties '[ 'PropertyKey "crossModule" 'TBoolean]+properties = emptyProperties+  & defineBooleanProperty #crossModule+    "Enable experimental cross-module renaming" False
+ plugins/hls-rename-plugin/test/Main.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import           Data.Aeson+import qualified Data.Map          as M+import           Ide.Plugin.Config+import qualified Ide.Plugin.Rename as Rename+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++renamePlugin :: PluginTestDescriptor Rename.Log+renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename"++-- See https://github.com/wz1000/HieDb/issues/45+recordConstructorIssue :: String+recordConstructorIssue = "HIE references for record fields incorrect with GHC versions >= 9"++tests :: TestTree+tests = testGroup "Rename"+    [ goldenWithRename "Data constructor" "DataConstructor" $ \doc ->+        rename doc (Position 0 15) "Op"+    , goldenWithRename "Exported function" "ExportedFunction" $ \doc ->+        rename doc (Position 2 1) "quux"+    , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $+      goldenWithRename "Field Puns" "FieldPuns" $ \doc ->+        rename doc (Position 7 13) "bleh"+    , goldenWithRename "Function argument" "FunctionArgument" $ \doc ->+        rename doc (Position 3 4) "y"+    , goldenWithRename "Function name" "FunctionName" $ \doc ->+        rename doc (Position 3 1) "baz"+    , goldenWithRename "GADT" "Gadt" $ \doc ->+        rename doc (Position 6 37) "Expr"+    , goldenWithRename "Hidden function" "HiddenFunction" $ \doc ->+        rename doc (Position 0 32) "quux"+    , goldenWithRename "Imported function" "ImportedFunction" $ \doc ->+        rename doc (Position 3 8) "baz"+    , goldenWithRename "Import hiding" "ImportHiding" $ \doc ->+        rename doc (Position 0 22) "hiddenFoo"+    , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $+      goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc ->+        rename doc (Position 4 23) "blah"+    , goldenWithRename "Let expression" "LetExpression" $ \doc ->+        rename doc (Position 5 11) "foobar"+    , goldenWithRename "Qualified as" "QualifiedAs" $ \doc ->+        rename doc (Position 3 10) "baz"+    , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc ->+        rename doc (Position 3 12) "foobar"+    , goldenWithRename "Qualified function" "QualifiedFunction" $ \doc ->+        rename doc (Position 3 12) "baz"+    , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc ->+        rename doc (Position 0 2) "fooBarQuux"+    , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $+      goldenWithRename "Record field" "RecordField" $ \doc ->+        rename doc (Position 6 9) "number"+    , goldenWithRename "Shadowed name" "ShadowedName" $ \doc ->+        rename doc (Position 1 1) "baz"+    , goldenWithRename "Typeclass" "Typeclass" $ \doc ->+        rename doc (Position 8 15) "Equal"+    , goldenWithRename "Type constructor" "TypeConstructor" $ \doc ->+        rename doc (Position 2 17) "BinaryTree"+    , goldenWithRename "Type variable" "TypeVariable" $ \doc ->+        rename doc (Position 0 13) "b"+    ]++goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithRename title path act =+    goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-rename-plugin" </> "test" </> "testdata"
+ plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs view
@@ -0,0 +1,4 @@+data Expr = Op Int Int++plus :: Expr -> Expr+plus (Op n m) = Op (n + m) 0
+ plugins/hls-rename-plugin/test/testdata/DataConstructor.hs view
@@ -0,0 +1,4 @@+data Expr = Apply Int Int++plus :: Expr -> Expr+plus (Apply n m) = Apply (n + m) 0
+ plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs view
@@ -0,0 +1,5 @@+module ExportedFunction (quux) where++quux :: Num p => [a] -> p+quux [] = 0+quux xs = 1
+ plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs view
@@ -0,0 +1,5 @@+module ExportedFunction (foo) where++foo :: Num p => [a] -> p+foo [] = 0+foo xs = 1
+ plugins/hls-rename-plugin/test/testdata/FieldPuns.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}++module FieldPun () where++newtype Foo = Foo { bleh :: Int }++unFoo :: Foo -> Int+unFoo Foo{bleh} = bleh
+ plugins/hls-rename-plugin/test/testdata/FieldPuns.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}++module FieldPun () where++newtype Foo = Foo { field :: Int }++unFoo :: Foo -> Int+unFoo Foo{field} = field
+ plugins/hls-rename-plugin/test/testdata/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++foo :: Int -> Int+foo x = 0
+ plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs view
@@ -0,0 +1,4 @@+module FunctionArgument () where++foo :: Int -> Int+foo y = y + 1
+ plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs view
@@ -0,0 +1,4 @@+module FunctionArgument () where++foo :: Int -> Int+foo x = x + 1
+ plugins/hls-rename-plugin/test/testdata/FunctionName.expected.hs view
@@ -0,0 +1,6 @@+main = do+    x <- return $ baz 42+    return (baz x)+baz, bar :: Int -> Int+baz x = x + 1+bar = (+ 1) . baz
+ plugins/hls-rename-plugin/test/testdata/FunctionName.hs view
@@ -0,0 +1,6 @@+main = do+    x <- return $ foo 42+    return (foo x)+foo, bar :: Int -> Int+foo x = x + 1+bar = (+ 1) . foo
+ plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE GADTs #-}++data Expr a where+    Number  :: Int -> Expr Int+    Boolean :: Bool -> Expr Bool+    Not     :: Expr Bool -> Expr Bool+    Even    :: Expr Int -> Expr Bool+    Add     :: Enum a => Expr a -> Expr a -> Expr Int+    Max     :: Ord a => Expr a -> Expr a -> Expr a++evaluate :: Expr a -> a+evaluate (Number n)  = n+evaluate (Boolean p) = p+evaluate (Add n m)   = fromEnum (evaluate n) + fromEnum (evaluate m)+evaluate (Even n)    = even $ evaluate n+evaluate (Not p)     = not $ evaluate p+evaluate (Max x y)   = max (evaluate x) (evaluate y)
+ plugins/hls-rename-plugin/test/testdata/Gadt.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE GADTs #-}++data Expression a where+    Number  :: Int -> Expression Int+    Boolean :: Bool -> Expression Bool+    Not     :: Expression Bool -> Expression Bool+    Even    :: Expression Int -> Expression Bool+    Add     :: Enum a => Expression a -> Expression a -> Expression Int+    Max     :: Ord a => Expression a -> Expression a -> Expression a++evaluate :: Expression a -> a+evaluate (Number n)  = n+evaluate (Boolean p) = p+evaluate (Add n m)   = fromEnum (evaluate n) + fromEnum (evaluate m)+evaluate (Even n)    = even $ evaluate n+evaluate (Not p)     = not $ evaluate p+evaluate (Max x y)   = max (evaluate x) (evaluate y)
+ plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs view
@@ -0,0 +1,4 @@+import           Foo hiding (quux)++foo :: Int -> Int+foo x = 0
+ plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs view
@@ -0,0 +1,4 @@+import           Foo hiding (foo)++foo :: Int -> Int+foo x = 0
+ plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs view
@@ -0,0 +1,4 @@+import Foo hiding (hiddenFoo)++foo :: Int -> Int+foo _ = 5
+ plugins/hls-rename-plugin/test/testdata/ImportHiding.hs view
@@ -0,0 +1,4 @@+import Foo hiding (foo)++foo :: Int -> Int+foo _ = 5
+ plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs view
@@ -0,0 +1,4 @@+import           Foo (baz)++bar :: Int -> Int+bar = baz
+ plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs view
@@ -0,0 +1,4 @@+import           Foo (foo)++bar :: Int -> Int+bar = foo
+ plugins/hls-rename-plugin/test/testdata/IndirectPuns.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}++module IndirectPuns () where++newtype Foo = Foo { blah :: Int }++unFoo :: Foo -> Int+unFoo Foo{blah} = blah
+ plugins/hls-rename-plugin/test/testdata/IndirectPuns.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}++module IndirectPuns () where++newtype Foo = Foo { field :: Int }++unFoo :: Foo -> Int+unFoo Foo{field} = field
+ plugins/hls-rename-plugin/test/testdata/LetExpression.expected.hs view
@@ -0,0 +1,10 @@+module Let () where++import Foo++bar :: Int+bar = let foobar = 5 in+    foobar * foobar++quux :: Int+quux = Foo.foo 4
+ plugins/hls-rename-plugin/test/testdata/LetExpression.hs view
@@ -0,0 +1,10 @@+module Let () where++import Foo++bar :: Int+bar = let foo = 5 in+    foo * foo++quux :: Int+quux = Foo.foo 4
+ plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs view
@@ -0,0 +1,4 @@+import qualified Foo as F++bar :: Int -> Int+bar = F.baz
+ plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs view
@@ -0,0 +1,4 @@+import qualified Foo as F++bar :: Int -> Int+bar = F.foo
+ plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs view
@@ -0,0 +1,4 @@+import qualified Foo++bar :: Int -> Int+bar = Foo.baz
+ plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs view
@@ -0,0 +1,4 @@+import qualified Foo++bar :: Int -> Int+bar = Foo.foo
+ plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs view
@@ -0,0 +1,7 @@+import qualified Foo as F++bar :: Int -> Int+bar x = F.foobar x + foo x++foo :: Int -> Int+foo _ = 5
+ plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs view
@@ -0,0 +1,7 @@+import qualified Foo as F++bar :: Int -> Int+bar x = F.foo x + foo x++foo :: Int -> Int+foo _ = 5
+ plugins/hls-rename-plugin/test/testdata/RealignDo.expected.hs view
@@ -0,0 +1,4 @@+fooBarQuux :: Maybe Integer+fooBarQuux = do x <- Just 5+                t <- Just 10+                pure $ x + t
+ plugins/hls-rename-plugin/test/testdata/RealignDo.hs view
@@ -0,0 +1,4 @@+foo :: Maybe Integer+foo = do x <- Just 5+         t <- Just 10+         pure $ x + t
+ plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs view
@@ -0,0 +1,7 @@+data Bam = Bam {+    number :: Int,+    s :: String+}++foo :: Bam -> Bam+foo Bam {number = y} = Bam {number = y + 5, s = ""}
+ plugins/hls-rename-plugin/test/testdata/RecordField.hs view
@@ -0,0 +1,7 @@+data Bam = Bam {+    n :: Int,+    s :: String+}++foo :: Bam -> Bam+foo Bam {n = y} = Bam {n = y + 5, s = ""}
+ plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs view
@@ -0,0 +1,4 @@+baz :: Int -> Int+baz x = foo + 10+    where+        foo = 20
+ plugins/hls-rename-plugin/test/testdata/ShadowedName.hs view
@@ -0,0 +1,4 @@+foo :: Int -> Int+foo x = foo + 10+    where+        foo = 20
+ plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs view
@@ -0,0 +1,5 @@+data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Leaf a++rotateRight :: BinaryTree a -> BinaryTree a+rotateRight (Node v (Node v' l' r') r) =  Node v' l' (Node v r' r)+rotateRight t                          = t
+ plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs view
@@ -0,0 +1,5 @@+data Tree a = Node a (Tree a) (Tree a) | Leaf a++rotateRight :: Tree a -> Tree a+rotateRight (Node v (Node v' l' r') r) =  Node v' l' (Node v r' r)+rotateRight t                          = t
+ plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs view
@@ -0,0 +1,2 @@+bar :: Maybe b -> Maybe b+bar a = a
+ plugins/hls-rename-plugin/test/testdata/TypeVariable.hs view
@@ -0,0 +1,2 @@+bar :: Maybe a -> Maybe a+bar a = a
+ plugins/hls-rename-plugin/test/testdata/Typeclass.expected.hs view
@@ -0,0 +1,10 @@+module Typeclass () where++class Equal a where+    equals :: a -> a -> Bool++instance Equal Int where+  equals = (==)++allEqual :: Equal a => [a] -> Bool+allEqual = all =<< equals . head
+ plugins/hls-rename-plugin/test/testdata/Typeclass.hs view
@@ -0,0 +1,10 @@+module Typeclass () where++class Equality a where+    equals :: a -> a -> Bool++instance Equality Int where+  equals = (==)++allEqual :: Equality a => [a] -> Bool+allEqual = all =<< equals . head
+ plugins/hls-rename-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,24 @@+cradle:+  direct:+    arguments:+      - "DataConstructor"+      - "ExportedFunction"+      - "FieldPuns"+      - "Foo"+      - "FunctionArgument"+      - "FunctionName"+      - "Gadt"+      - "HiddenFunction"+      - "ImportHiding"+      - "ImportedFunction"+      - "IndirectPuns"+      - "LetExpression"+      - "QualifiedAs"+      - "QualifiedFunction"+      - "QualifiedShadowing"+      - "RealignDo"+      - "RecordField"+      - "ShadowedName"+      - "TypeClass"+      - "TypeConstructor"+      - "TypeVariable"
+ plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs view
@@ -0,0 +1,789 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}++{-# OPTIONS -Wno-orphans #-}++module Ide.Plugin.Retrie (descriptor) where++import           Control.Concurrent.STM               (readTVarIO)+import           Control.Exception.Safe               (Exception (..),+                                                       SomeException, assert,+                                                       catch, throwIO, try)+import           Control.Lens.Operators+import           Control.Monad                        (forM, unless, when)+import           Control.Monad.Error.Class            (MonadError (throwError))+import           Control.Monad.IO.Class               (MonadIO (liftIO))+import           Control.Monad.Trans.Class            (MonadTrans (lift))+import           Control.Monad.Trans.Except           (ExceptT (..), runExceptT)++import           Control.Monad.Trans.Maybe            (MaybeT)+import           Data.Aeson                           (FromJSON (..),+                                                       ToJSON (..))+import           Data.Bifunctor                       (second)+import qualified Data.ByteString                      as BS+import           Data.Data+import           Data.Either                          (partitionEithers)+import           Data.Hashable                        (unhashed)+import qualified Data.HashSet                         as Set+import           Data.IORef.Extra                     (atomicModifyIORef'_,+                                                       newIORef, readIORef)+import           Data.List.Extra                      (find, nubOrdOn)+import qualified Data.Map                             as Map+import           Data.Maybe                           (catMaybes)+import           Data.Monoid                          (First (First))+import           Data.String                          (IsString)+import qualified Data.Text                            as T+import qualified Data.Text.Encoding                   as T+import           Development.IDE                      hiding (pluginHandlers)+import           Development.IDE.Core.Actions         (lookupMod)+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.Shake           (ShakeExtras (ShakeExtras, knownTargetsVar),+                                                       getShakeExtras,+                                                       hiedbWriter,+                                                       toKnownFiles, withHieDb)+import           Development.IDE.GHC.Compat           (GRHSs (GRHSs),+                                                       GenLocated (L), GhcPs,+                                                       GhcRn,+                                                       HsBindLR (FunBind),+                                                       HsExpr (HsApp, OpApp),+                                                       HsGroup (..),+                                                       HsValBindsLR (..),+                                                       HscEnv, ImportDecl (..),+                                                       LHsExpr, LRuleDecls,+                                                       Match, ModIface,+                                                       ModSummary (ModSummary, ms_hspp_buf, ms_mod),+                                                       Outputable, ParsedModule,+                                                       RuleDecl (HsRule),+                                                       RuleDecls (HsRules),+                                                       SourceText (..),+                                                       TyClDecl (SynDecl),+                                                       TyClGroup (..), fun_id,+                                                       isQual, isQual_maybe,+                                                       locA, mi_fixities,+                                                       moduleNameString,+                                                       ms_hspp_opts,+                                                       nameModule_maybe,+                                                       nameOccName, nameRdrName,+                                                       noLocA, occNameFS,+                                                       occNameString,+                                                       pattern IsBoot,+                                                       pattern NotBoot,+                                                       pattern RealSrcSpan,+                                                       pm_parsed_source,+                                                       rdrNameOcc, rds_rules,+                                                       srcSpanFile, topDir,+                                                       unLoc, unLocA)+import qualified Development.IDE.GHC.Compat           as GHC+import           Development.IDE.GHC.Compat.Util      hiding (catch, try)+import           Development.IDE.GHC.ExactPrint       (GetAnnotatedParsedSource (GetAnnotatedParsedSource),+                                                       TransformT)+import           Development.IDE.Spans.AtPoint        (LookupModule,+                                                       nameToLocation)+import           Development.IDE.Types.Shake          (WithHieDb)+import qualified GHC                                  as GHCGHC+import           GHC.Generics                         (Generic)+import           Ide.Plugin.Error                     (PluginError (PluginInternalError),+                                                       getNormalizedFilePathE)+import           Ide.PluginUtils+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message        as LSP+import           Language.LSP.Protocol.Types          as LSP+import           Language.LSP.Server                  (ProgressCancellable (Cancellable),+                                                       sendNotification,+                                                       sendRequest,+                                                       withIndefiniteProgress)+import           Retrie                               (Annotated (astA),+                                                       AnnotatedModule,+                                                       Fixity (Fixity),+                                                       FixityDirection (InfixL),+                                                       Options, Options_ (..),+                                                       Verbosity (Loud),+                                                       addImports, apply,+                                                       applyWithUpdate)+import           Retrie.Context+import           Retrie.CPP                           (CPP (NoCPP), parseCPP)+import           Retrie.ExactPrint                    (fix, makeDeltaAst,+                                                       transformA, unsafeMkA)+import           Retrie.Expr                          (mkLocatedHsVar)+import           Retrie.Fixity                        (FixityEnv, lookupOp,+                                                       mkFixityEnv)+import           Retrie.Monad                         (getGroundTerms,+                                                       runRetrie)+import           Retrie.Options                       (defaultOptions,+                                                       getTargetFiles)+import           Retrie.Replace                       (Change (..),+                                                       Replacement (..))+import           Retrie.Rewrites+import           Retrie.Rewrites.Function             (matchToRewrites)+import           Retrie.SYB                           (everything, extQ,+                                                       listify, mkQ)+import           Retrie.Types+import           Retrie.Universe                      (Universe)+import           System.Directory                     (makeAbsolute)++#if MIN_VERSION_ghc(9,3,0)+import           GHC.Types.PkgQual+#endif++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId =+  (defaultPluginDescriptor plId "Provides code actions to inline Haskell definitions")+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider,+      pluginCommands = [retrieCommand, retrieInlineThisCommand]+    }++retrieCommandId :: CommandId+retrieCommandId = "retrieCommand"++retrieInlineThisCommandId :: CommandId+retrieInlineThisCommandId = "retrieInlineThisCommand"++retrieCommand :: PluginCommand IdeState+retrieCommand =+  PluginCommand retrieCommandId "run the refactoring" runRetrieCmd++retrieInlineThisCommand :: PluginCommand IdeState+retrieInlineThisCommand =+  PluginCommand retrieInlineThisCommandId "inline function call"+     runRetrieInlineThisCmd++-- | Parameters for the runRetrie PluginCommand.+data RunRetrieParams = RunRetrieParams+  { description               :: T.Text,+    rewrites                  :: [RewriteSpec],+    originatingFile           :: Uri,+    restrictToOriginatingFile :: Bool+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++runRetrieCmd :: CommandFunction IdeState RunRetrieParams+runRetrieCmd state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $+  withIndefiniteProgress description token Cancellable $ \_updater -> do+    _ <- runExceptT $ do+        nfp <- getNormalizedFilePathE uri+        (session, _) <-+            runActionE "Retrie.GhcSessionDeps" state $+                useWithStaleE GhcSessionDeps+                nfp+        (ms, binds, _, _, _) <- runActionE "Retrie.getBinds" state $ getBinds nfp+        let importRewrites = concatMap (extractImports ms binds) rewrites+        (errors, edits) <- liftIO $+            callRetrie+                state+                (hscEnv session)+                (map Right rewrites <> map Left importRewrites)+                nfp+                restrictToOriginatingFile+        unless (null errors) $+            lift $ sendNotification SMethod_WindowShowMessage $+                    ShowMessageParams MessageType_Warning $+                    T.unlines $+                        "## Found errors during rewrite:" :+                        ["-" <> T.pack (show e) | e <- errors]+        _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ())+        return ()+    return $ Right $ InR Null++data RunRetrieInlineThisParams = RunRetrieInlineThisParams+  { inlineIntoThisLocation :: !Location,+    inlineFromThisLocation :: !Location,+    inlineThisDefinition   :: !T.Text+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams+runRetrieInlineThisCmd state _token RunRetrieInlineThisParams{..} = do+    nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation+    nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation+    -- What we do here:+    --   Find the identifier in the given position+    --   Construct an inline rewrite for it+    --   Run retrie to get a list of changes+    --   Select the change that inlines the identifier in the given position+    --   Apply the edit+    astSrc <- runActionE "retrie" state $+        useE GetAnnotatedParsedSource nfpSource+    let fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation+        intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation+    inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange+    when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite"+    (session, _) <- runActionE "retrie" state $+      useWithStaleE GhcSessionDeps nfp+    (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp+    result <- liftIO $ try @_ @SomeException $+        runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp+    case result of+        Left err -> throwError $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err)+        Right (_,_,NoChange) -> throwError $ PluginInternalError "Retrie - inline produced no changes"+        Right (_,_,Change replacements imports) -> do+            let edits = asEditMap $ asTextEdits $ Change ourReplacement imports+                wedit = WorkspaceEdit (Just edits) Nothing Nothing+                ourReplacement = [ r+                    | r@Replacement{..} <- replacements+                    , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation]+            _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit+                (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+            return $ InR Null++-- Override to skip adding binders to the context, which prevents inlining+-- nested defined functions+myContextUpdater :: ContextUpdater+myContextUpdater c i =+    updateContext c i+    `extQ` (return . updExp)+    `extQ` (skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs)))+    `extQ` (skipUpdate @(Match GhcPs (LHsExpr GhcPs)))+  where+    skipUpdate :: forall a m . Monad m => a -> TransformT m Context+    skipUpdate _ = pure c++    -- override to skip the HsLet case+    updExp :: HsExpr GhcPs -> Context+    updExp HsApp{} =+        c { ctxtParentPrec = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }+    -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)+    -- In left child, prec is 10, so HsApp child will NOT get paren'd+    -- In right child, prec is 11, so every child gets paren'd (unless atomic)+    updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }+    updExp _ = c { ctxtParentPrec = NeverParen }+    -- Deal with Trees-That-Grow adding extension points+    -- as the first child everywhere.+    firstChild :: Int+    firstChild = 1++extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]+extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing)+  | Just FunBind {fun_matches}+  <- find (\case FunBind{fun_id = L _ n} -> T.unpack (printOutputable n) == thing ; _ -> False) topLevelBinds+  , names <- listify p fun_matches+  =+    [ AddImport {..}+    | let ideclSource = False,+        name <- names,+        let r = nameRdrName name,+        let ideclQualifiedBool = isQual r,+        let ideclAsString = moduleNameString . fst <$> isQual_maybe r,+        let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r),+        Just ideclNameString <-+        [moduleNameString . GHC.moduleName <$> nameModule_maybe name]+    ]+    where+        p name = nameModule_maybe name /= Just ms_mod+-- TODO handle imports for all rewrites+extractImports _ _ _ = []++-------------------------------------------------------------------------------++provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = do+  let (LSP.CodeActionContext _diags _monly _) = ca+  nfp <- getNormalizedFilePathE uri++  (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)+    <- runActionE "retrie" state $+        getBinds nfp++  extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras++  range <- fromCurrentRangeE posMapping range+  let pos = range ^. L.start+  let rewrites =+        concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds+          ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds+          ++ [ r+               | TyClGroup {group_tyclds} <- hs_tyclds,+                 L (locA -> l) g <- group_tyclds,+                 pos `isInsideSrcSpan` l,+                 r <- suggestTypeRewrites uri ms_mod g+             ]++  retrieCommands <- lift $+    forM rewrites $ \(title, kind, params) -> liftIO $ do+      let c = mkLspCommand plId retrieCommandId title (Just [toJSON params])+      return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing++  inlineSuggestions <- liftIO $ runIdeAction "" extras $+    suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter)+  let inlineCommands =+        [ Just $+            CodeAction _title (Just CodeActionKind_RefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing+        | c@Command{..} <- inlineSuggestions+        ]+  return $ InL [InR c | c <- retrieCommands ++ catMaybes inlineCommands]++getLocationUri :: Location -> Uri+getLocationUri Location{_uri} = _uri++getLocationRange :: Location -> Range+getLocationRange Location{_range} = _range++getBinds :: NormalizedFilePath -> ExceptT PluginError Action+  ( ModSummary+  , [HsBindLR GhcRn GhcRn]+  , PositionMapping+  , [LRuleDecls GhcRn]+  , [TyClGroup GhcRn]+  )+getBinds nfp = do+  (tm, posMapping) <- useWithStaleE TypeCheck nfp+  -- we use the typechecked source instead of the parsed source+  -- to be able to extract module names from the Ids,+  -- so that we can include adding the required imports in the retrie command+  let rn = tmrRenamed tm+  case rn of+    (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _) -> do+      topLevelBinds <- case hs_valds of+        ValBinds{} -> throwError $ PluginInternalError "getBinds: ValBinds not supported"+        XValBindsLR (GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn) ->+          pure [ decl+               | (_, bagBinds) <- binds+               , L _ decl <- bagToList bagBinds+               ]+      return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)++suggestBindRewrites ::+  Uri ->+  Position ->+  GHC.Module ->+  HsBindLR GhcRn GhcRn ->+  [(T.Text, CodeActionKind, RunRetrieParams)]+suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName}+  | pos `isInsideSrcSpan` l' =+    let pprNameText = printOutputable rdrName+        pprName = T.unpack pprNameText+        unfoldRewrite restrictToOriginatingFile =+            let rewrites = [Unfold (qualify ms_mod pprName)]+                description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile+            in (description, CodeActionKind_RefactorInline, RunRetrieParams {..})+        foldRewrite restrictToOriginatingFile =+          let rewrites = [Fold (qualify ms_mod pprName)]+              description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile+           in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..})+     in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]+suggestBindRewrites _ _ _ _ = []++  -- find all the identifiers in the AST for which have source definitions+suggestBindInlines ::+    PluginId+    -> Uri+    -> [HsBindLR GhcRn GhcRn]+    -> Range+    -> WithHieDb+    -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)+    -> IdeAction [Command]+suggestBindInlines plId _uri binds range hie lookupMod = do+    identifiers <- definedIdentifiers+    return $ map (\(name, siteLoc, srcLoc) ->+        let+            title = "Inline " <> printedName+            printedName = printOutputable name+            params = RunRetrieInlineThisParams+                { inlineIntoThisLocation = siteLoc+                , inlineFromThisLocation = srcLoc+                , inlineThisDefinition= printedName+                }+        in mkLspCommand plId retrieInlineThisCommandId title (Just [toJSON params])+        )+        (Set.toList identifiers)+    where+      definedIdentifiers =+        -- we search for candidates to inline in RHSs only, skipping LHSs+        everything (<>) (pure mempty `mkQ` getGRHSIdentifierDetails hie lookupMod) binds++      getGRHSIdentifierDetails ::+        WithHieDb+        -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)+        -> GRHSs GhcRn (LHsExpr GhcRn)+        -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))+      getGRHSIdentifierDetails a b it@GRHSs{} =+        -- we only select candidates for which we have source code+        everything (<>) (pure mempty `mkQ` getDefinedIdentifierDetailsViaHieDb a b) it++      getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))+      getDefinedIdentifierDetailsViaHieDb withHieDb lookupModule lname | name <- unLoc lname =+        case srcSpanToLocation (GHC.getLocA lname) of+            Just siteLoc+              | siteRange <- getLocationRange siteLoc+              , range `isSubrangeOf` siteRange -> do+                    mbSrcLocation <- nameToLocation withHieDb lookupModule name+                    return $ maybe mempty (Set.fromList . map (nameOccName name, siteLoc,)) mbSrcLocation+            _ -> pure mempty+++describeRestriction :: IsString p => Bool -> p+describeRestriction restrictToOriginatingFile =+        if restrictToOriginatingFile then " in current file" else ""++suggestTypeRewrites ::+  Uri ->+  GHC.Module ->+  TyClDecl GhcRn ->+  [(T.Text, CodeActionKind, RunRetrieParams)]+suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} =+    let pprNameText = printOutputable (unLocA tcdLName)+        pprName = T.unpack pprNameText+        unfoldRewrite restrictToOriginatingFile =+            let rewrites = [TypeForward (qualify ms_mod pprName)]+                description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile+           in (description, CodeActionKind_RefactorInline, RunRetrieParams {..})+        foldRewrite restrictToOriginatingFile =+          let rewrites = [TypeBackward (qualify ms_mod pprName)]+              description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile+           in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..})+     in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]+suggestTypeRewrites _ _ _ = []++suggestRuleRewrites ::+  Uri ->+  Position ->+  GHC.Module ->+  LRuleDecls GhcRn ->+  [(T.Text, CodeActionKind, RunRetrieParams)]+suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =+    concat+        [ [ forwardRewrite   ruleName True+          , forwardRewrite   ruleName False+          , backwardsRewrite ruleName True+          , backwardsRewrite ruleName False+          ]+        | L (locA -> l) r  <- rds_rules,+          pos `isInsideSrcSpan` l,+#if MIN_VERSION_ghc(9,5,0)+          let HsRule {rd_name = L _ rn} = r,+#else+          let HsRule {rd_name = L _ (_, rn)} = r,+#endif+          let ruleName = unpackFS rn+      ]+  where+    forwardRewrite ruleName restrictToOriginatingFile =+        let rewrites = [RuleForward (qualify ms_mod ruleName)]+            description = "Apply rule " <> T.pack ruleName <> " forward" <>+                            describeRestriction restrictToOriginatingFile++        in ( description,+            CodeActionKind_Refactor,+            RunRetrieParams {..}+            )+    backwardsRewrite ruleName restrictToOriginatingFile =+          let rewrites = [RuleBackward (qualify ms_mod ruleName)]+              description = "Apply rule " <> T.pack ruleName <> " backwards" <>+                              describeRestriction restrictToOriginatingFile+           in ( description,+                CodeActionKind_Refactor,+                RunRetrieParams {..}+              )++qualify :: Outputable mod => mod -> String -> String+qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x++-------------------------------------------------------------------------------+-- Retrie driving code++data CallRetrieError+  = CallRetrieInternalError String NormalizedFilePath+  | NoParse NormalizedFilePath+  | GHCParseError NormalizedFilePath String+  | NoTypeCheck NormalizedFilePath+  deriving (Eq, Typeable)++instance Show CallRetrieError where+  show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f+  show (NoParse f) = "Cannot parse: " <> fromNormalizedFilePath f+  show (GHCParseError f m) = "Cannot parse " <> fromNormalizedFilePath f <> " : " <> m+  show (NoTypeCheck f) = "File does not typecheck: " <> fromNormalizedFilePath f++instance Exception CallRetrieError++callRetrie ::+  IdeState ->+  HscEnv ->+  [Either ImportSpec RewriteSpec] ->+  NormalizedFilePath ->+  Bool ->+  IO ([CallRetrieError], WorkspaceEdit)+callRetrie state session rewrites origin restrictToOriginatingFile = do+  knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)+  let+      -- TODO cover all workspaceFolders+      target = "."++      retrieOptions :: Retrie.Options+      retrieOptions = (defaultOptions target)+        {Retrie.verbosity = Loud+        ,Retrie.targetFiles = map fromNormalizedFilePath $+            if restrictToOriginatingFile+                then [origin]+                else Set.toList knownFiles+        }++      (theImports, theRewrites) = partitionEithers rewrites++      annotatedImports =+        unsafeMkA (map (noLocA . toImportDecl) theImports) 0++  (originFixities, originParsedModule) <- reuseParsedModule state origin+  retrie <-+    (\specs -> apply specs >> addImports annotatedImports)+      <$> parseSpecs state origin originParsedModule originFixities theRewrites++  targets <- getTargetFiles retrieOptions (getGroundTerms retrie)++  results <- forM targets $ \t -> runExceptT $ do+    (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t+    -- TODO add the imports to the resulting edits+    (_user, _ast, change@(Change _replacements _imports)) <-+      lift $ runRetrie fixityEnv retrie cpp+    return $ asTextEdits change++  let (errors :: [CallRetrieError], replacements) = partitionEithers results+      editParams :: WorkspaceEdit+      editParams =+        WorkspaceEdit (Just $ asEditMap $ concat replacements) Nothing Nothing++  return (errors, editParams)++useOrFail ::+  IdeRule r v =>+  IdeState ->+  String ->+  (NormalizedFilePath -> CallRetrieError) ->+  r ->+  NormalizedFilePath ->+  IO (RuleResult r)+useOrFail state lbl mkException rule f =+  useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return++fixityEnvFromModIface :: ModIface -> FixityEnv+fixityEnvFromModIface modIface =+  mkFixityEnv+    [ (fs, (fs, fixity))+      | (n, fixity) <- mi_fixities modIface,+        let fs = occNameFS n+    ]++fixFixities :: Data ast =>+  IdeState+  -> NormalizedFilePath+  -> Annotated ast+  -> IO (FixityEnv, Annotated ast)+fixFixities state f pm = do+      HiFileResult {hirModIface} <-+        useOrFail state "GetModIface" NoTypeCheck GetModIface f+      let fixities = fixityEnvFromModIface hirModIface+      res <- transformA pm (fix fixities)+      return (fixities, res)++fixAnns :: ParsedModule -> Annotated GHC.ParsedSource+fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0++parseSpecs+  :: IdeState+  -> NormalizedFilePath+  -> AnnotatedModule+  -> FixityEnv+  -> [RewriteSpec]+  -> IO [Rewrite Universe]+parseSpecs state origin originParsedModule originFixities specs = do+  -- retrie needs the libdir for `parseRewriteSpecs`+  libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin+  parseRewriteSpecs+    libdir+    (\_f -> return $ NoCPP originParsedModule)+    originFixities+    specs++constructfromFunMatches ::+  Annotated [GHCGHC.LocatedA (ImportDecl GhcPs)]+  -> GHCGHC.LocatedN GHCGHC.RdrName+  -> GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))+  -> TransformT IO [Rewrite Universe]+constructfromFunMatches imps fun_id fun_matches = do+    fe <- mkLocatedHsVar fun_id+    rewrites <- concat <$>+        forM (unLoc $ GHC.mg_alts fun_matches) (matchToRewrites fe imps LeftToRight)+    let urewrites = toURewrite <$> rewrites+    -- traceShowM $ map showQuery urewrites+    assert (not $ null urewrites) $+        return urewrites++-- showQuery :: Rewrite Universe -> String+-- showQuery = ppRewrite+--+-- showQuery :: Rewrite (LHsExpr GhcPs) -> String+-- showQuery q = unlines+--     [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q))+--     , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q))))+--     , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q))+--     ]+--+-- s :: Data a => a -> String+-- s = T.unpack . printOutputable . showAstData NoBlankSrcSpan+--         NoBlankEpAnnotations++constructInlineFromIdentifer :: Data a => Annotated (GenLocated l a) -> GHCGHC.RealSrcSpan -> IO [Rewrite Universe]+constructInlineFromIdentifer originParsedModule originSpan = do+    -- traceM $ s $ astA originParsedModule+    fmap astA $ transformA originParsedModule $ \(L _ m) -> do+        let ast = everything (<>) (First Nothing `mkQ` matcher) m+            matcher :: HsBindLR GhcPs GhcPs+                -> First ( GHCGHC.LocatedN GHCGHC.RdrName+                         , GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))+                         )+            matcher FunBind{fun_id, fun_matches}+                -- trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined+                | RealSrcSpan sp _ <- GHC.getLocA fun_id+                , sp == originSpan =+                First $ Just (fun_id, fun_matches)+            matcher _ = First Nothing+        case ast of+            First (Just (fun_id, fun_matches))+                ->+                let imports = mempty in+                constructfromFunMatches imports fun_id fun_matches+            _ -> return $ error "could not find source code to inline"++asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit]+asEditMap = Map.fromListWith (++) . map (second pure)++asTextEdits :: Change -> [(Uri, TextEdit)]+asTextEdits NoChange = []+asTextEdits (Change reps _imports) =+  [ (filePathToUri spanLoc, edit)+    | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps,+      (RealSrcSpan rspan _) <- [replLocation],+      let spanLoc = unpackFS $ srcSpanFile rspan,+      let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement)+  ]++-------------------------------------------------------------------------------+-- Rule wrappers++_useRuleBlocking,+  _useRuleStale,+  useRule ::+    (IdeRule k v) =>+    String ->+    IdeState ->+    k ->+    NormalizedFilePath ->+    IO (Maybe (RuleResult k))+_useRuleBlocking label state rule f = runAction label state (use rule f)+_useRuleStale label state rule f =+  fmap fst+    <$> runIdeAction label (shakeExtras state) (useWithStaleFast rule f)++-- | Chosen approach for calling ghcide Shake rules+useRule label = _useRuleStale ("Retrie." <> label)++-------------------------------------------------------------------------------+-- Serialization wrappers and instances++deriving instance Eq RewriteSpec++deriving instance Show RewriteSpec++deriving instance Generic RewriteSpec++deriving instance FromJSON RewriteSpec++deriving instance ToJSON RewriteSpec++newtype IE name+  = IEVar name+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)+++data ImportSpec = AddImport+  { ideclNameString    :: String,+    ideclSource        :: Bool,+    ideclQualifiedBool :: Bool,+    ideclAsString      :: Maybe String,+    ideclThing         :: Maybe (IE String)+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs+toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..}+  where+    ideclSource' = if ideclSource then IsBoot else NotBoot+    toMod = noLocA . GHC.mkModuleName+    ideclName = toMod ideclNameString+    ideclSafe = False+    ideclImplicit = False+    ideclSourceSrc = NoSourceText+    ideclAs = toMod <$> ideclAsString+    ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified++#if MIN_VERSION_ghc(9,3,0)+    ideclPkgQual = NoRawPkgQual+#else+    ideclPkgQual = Nothing+#endif++#if MIN_VERSION_ghc(9,5,0)+    ideclImportList = Nothing+    ideclExt = GHCGHC.XImportDeclPass+      { ideclAnn = GHCGHC.EpAnnNotUsed+      , ideclSourceText = ideclSourceSrc+      , ideclImplicit = ideclImplicit+      }+#else+    ideclExt = GHCGHC.EpAnnNotUsed+    ideclHiding = Nothing+#endif+++reuseParsedModule :: IdeState -> NormalizedFilePath -> IO (FixityEnv, Annotated GHCGHC.ParsedSource)+reuseParsedModule state f = do+        pm <- useOrFail state "Retrie.GetParsedModule" NoParse GetParsedModule f+        (fixities, pm') <- fixFixities state f (fixAnns pm)+        return (fixities, pm')++getCPPmodule :: IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule)+getCPPmodule state session t = do+    nt <- toNormalizedFilePath' <$> makeAbsolute t+    let getParsedModule f contents = do+          modSummary <- msrModSummary <$>+            useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt+          let ms' =+                modSummary+                  { ms_hspp_buf =+                      Just (stringToStringBuffer contents)+                  }+          logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t+          parsed <- evalGhcEnv session (GHCGHC.parseModule ms')+              `catch` \e -> throwIO (GHCParseError nt (show @SomeException e))+          (fixities, parsed) <- fixFixities state f (fixAnns parsed)+          return (fixities, parsed)++    contents <- do+      (_, mbContentsVFS) <-+        runAction "Retrie.GetFileContents" state $ getFileContents nt+      case mbContentsVFS of+        Just contents -> return contents+        Nothing       -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt)+    if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents)+      then do+        fixitiesRef <- newIORef mempty+        let parseModule x = do+              (fix, res) <- getParsedModule nt x+              atomicModifyIORef'_ fixitiesRef (fix <>)+              return res+        res <- parseCPP parseModule contents+        fixities <- readIORef fixitiesRef+        return (fixities, res)+      else do+        (fixities, pm) <- reuseParsedModule state nt+        return (fixities, NoCPP pm)
+ plugins/hls-retrie-plugin/test/Main.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE PartialTypeSignatures    #-}++module Main (main) where++import           Control.Monad                     (void)+import qualified Data.Map                          as M+import           Data.Text                         (Text)+import qualified Development.IDE.GHC.ExactPrint+import qualified Development.IDE.Plugin.CodeAction as Refactor+import           Ide.Plugin.Config+import qualified Ide.Plugin.Retrie                 as Retrie+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++retriePlugin :: PluginTestDescriptor a+retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie"++refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log+refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor"++tests :: TestTree+tests = testGroup "Retrie"+    [ inlineThisTests+    ]++inlineThisTests :: TestTree+inlineThisTests = testGroup "Inline this"+    [+        testGroup "provider" [+            testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"],+            testProvider "identifier" "Identity" 4 16 ["Inline identity"],+            testProvider "imported identifier" "Imported" 4 12 ["Inline identity"],+            testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"],+            testProvider "nested let" "NestedLet" 6 12 ["Inline identity"],+            testProvider "class member" "Class" 5 16 [],+            testProvider "operator" "Operator" 4 16 ["Inline */"]+        ],+        testGroup "command" [+            testCommand "top level function" "Identity" 4 16,+            testCommand "top level function in another file" "Imported" 4 12,+            testCommand "nested where function" "NestedWhere" 4 16,+            testCommand "nested let function" "NestedLet" 6 12,+            testCommand "operator" "Operator" 4 16+        ]+    ]++testProvider :: TestName -> FilePath -> UInt -> UInt -> [Text] -> TestTree+testProvider title file line row expected = testCase title $ runWithRetrie $ do+    adoc <- openDoc (file <.> "hs") "haskell"+    _ <- waitForTypecheck adoc+    let position = Position line row+    codeActions <- getCodeActions adoc $ Range position position+    liftIO $ map codeActionTitle codeActions @?= map Just expected++testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree+testCommand title file row col = goldenWithRetrie title file $ \adoc -> do+    _ <- waitForTypecheck adoc+    let p = Position row col+    codeActions <- getCodeActions adoc $ Range p p+    case codeActions of+        [InR ca] -> do+            executeCodeAction ca+            void $ skipManyTill anyMessage $ getDocumentEdit adoc+        cas -> liftIO . assertFailure $ "One code action expected, got " <> show (length cas)++codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle (InR CodeAction {_title}) = Just _title+codeActionTitle _                         = Nothing++goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithRetrie title path act =+    goldenWithHaskellDoc (def { plugins = M.fromList [("retrie", def)] }) testPlugins title testDataDir path "expected" "hs" act++runWithRetrie :: Session a -> IO a+runWithRetrie = runSessionWithServer def testPlugins testDataDir++testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log+testPlugins =+    retriePlugin <>+    refactorPlugin  -- needed for the GetAnnotatedParsedSource rule++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-retrie-plugin" </> "test" </> "testdata"
+ plugins/hls-retrie-plugin/test/testdata/Class.hs view
@@ -0,0 +1,7 @@+module Class where++class Identity x where+    identity :: x -> x+    identity x = x++function x = identity x
+ plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs view
@@ -0,0 +1,5 @@+module Identity where++identity x = x++function x = x
+ plugins/hls-retrie-plugin/test/testdata/Identity.hs view
@@ -0,0 +1,5 @@+module Identity where++identity x = x++function x = identity x
+ plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs view
@@ -0,0 +1,5 @@+module Imported where++import Identity++f x = x
+ plugins/hls-retrie-plugin/test/testdata/Imported.hs view
@@ -0,0 +1,5 @@+module Imported where++import Identity++f x = identity x
+ plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs view
@@ -0,0 +1,7 @@+module Nested where++++function x = x+  where+    identity x = x
+ plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs view
@@ -0,0 +1,7 @@+module NestedLet where++++function x =+    let identity x = x+    in x
+ plugins/hls-retrie-plugin/test/testdata/NestedLet.hs view
@@ -0,0 +1,7 @@+module NestedLet where++++function x =+    let identity x = x+    in identity x
+ plugins/hls-retrie-plugin/test/testdata/NestedNested.hs view
@@ -0,0 +1,10 @@++module NestedNested where++++function x = meme x+  where+    meme x = identity x+    identity x = x+
+ plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs view
@@ -0,0 +1,7 @@+module NestedWhere where++++function x = x+  where+    identity x = x
+ plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs view
@@ -0,0 +1,7 @@+module NestedWhere where++++function x = identity x+  where+    identity x = x
+ plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs view
@@ -0,0 +1,5 @@+module Operator where++x */ y = x++function x = x
+ plugins/hls-retrie-plugin/test/testdata/Operator.hs view
@@ -0,0 +1,5 @@+module Operator where++x */ y = x++function x = x */ ()
+ plugins/hls-retrie-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,11 @@+cradle:+    direct:+      arguments:+        - Class.hs+        - Identity.hs+        - Imported.hs+        - Nested.hs+        - NestedLet.hs+        - NestedNested.hs+        - NestedWhere.hs+        - Operator.hs
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+++module Ide.Plugin.SemanticTokens (descriptor) where++import           Development.IDE+import qualified Ide.Plugin.SemanticTokens.Internal as Internal+import           Ide.Plugin.SemanticTokens.Types+import           Ide.Types+import           Language.LSP.Protocol.Message++descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+  (defaultPluginDescriptor plId "Provides semantic tokens")+    { Ide.Types.pluginHandlers =+        mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder)+        <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder),+      Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder,+      pluginConfigDescriptor =+        defaultConfigDescriptor+          { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}+          , configCustomConfig = mkCustomConfig Internal.semanticConfigProperties+          }+    }
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UnicodeSyntax       #-}++-- |+-- This module provides the core functionality of the plugin.+module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where++import           Control.Concurrent.STM                   (stateTVar)+import           Control.Concurrent.STM.Stats             (atomically)+import           Control.Lens                             ((^.))+import           Control.Monad.Except                     (ExceptT, liftEither,+                                                           withExceptT)+import           Control.Monad.IO.Class                   (MonadIO (..))+import           Control.Monad.Trans                      (lift)+import           Control.Monad.Trans.Except               (runExceptT)+import qualified Data.Map.Strict                          as M+import           Data.Text                                (Text)+import qualified Data.Text                                as T+import           Development.IDE                          (Action,+                                                           GetDocMap (GetDocMap),+                                                           GetHieAst (GetHieAst),+                                                           HieAstResult (HAR, hieAst, hieModule, refMap),+                                                           IdeResult, IdeState,+                                                           Priority (..),+                                                           Recorder, Rules,+                                                           WithPriority,+                                                           cmapWithPrio, define,+                                                           fromNormalizedFilePath,+                                                           hieKind, use_)+import           Development.IDE.Core.PluginUtils         (runActionE,+                                                           useWithStaleE)+import           Development.IDE.Core.Rules               (toIdeResult)+import           Development.IDE.Core.RuleTypes           (DocAndTyThingMap (..))+import           Development.IDE.Core.Shake               (ShakeExtras (..),+                                                           getShakeExtras,+                                                           getVirtualFile,+                                                           useWithStale_)+import           Development.IDE.GHC.Compat               hiding (Warning)+import           Development.IDE.GHC.Compat.Util          (mkFastString)+import           Ide.Logger                               (logWith)+import           Ide.Plugin.Error                         (PluginError (PluginInternalError),+                                                           getNormalizedFilePathE,+                                                           handleMaybe,+                                                           handleMaybeM)+import           Ide.Plugin.SemanticTokens.Mappings+import           Ide.Plugin.SemanticTokens.Query+import           Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)+import           Ide.Plugin.SemanticTokens.Tokenize       (computeRangeHsSemanticTokenTypeList)+import           Ide.Plugin.SemanticTokens.Types+import           Ide.Types+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Message            (MessageResult,+                                                           Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))+import           Language.LSP.Protocol.Types              (NormalizedFilePath,+                                                           SemanticTokens,+                                                           type (|?) (InL, InR))+import           Prelude                                  hiding (span)+import qualified StmContainers.Map                        as STM+++$mkSemanticConfigFunctions++-----------------------+---- the api+-----------------------++computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens+computeSemanticTokens recorder pid _ nfp = do+  config <- lift $ useSemanticConfigAction pid+  logWith recorder Debug (LogConfig config)+  semanticId <- lift getAndIncreaseSemanticTokensId+  (RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp+  withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList++semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull+semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull+  where+    computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull)+    computeSemanticTokensFull = do+      nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)+      items <- computeSemanticTokens recorder pid state nfp+      lift $ setSemanticTokens nfp items+      return $ InL items+++semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta+semanticTokensFullDelta recorder state pid param = do+  nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)+  let previousVersionFromParam = param ^. L.previousResultId+  runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam  pid state nfp+  where+    computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta)+    computeSemanticTokensFullDelta recorder previousVersionFromParam  pid state nfp = do+      semanticTokens <- computeSemanticTokens recorder pid state nfp+      previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp+      lift $ setSemanticTokens nfp semanticTokens+      case previousSemanticTokensMaybe of+          Nothing -> return $ InL semanticTokens+          Just previousSemanticTokens ->+              if Just previousVersionFromParam == previousSemanticTokens^.L.resultId+              then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens+              else do+                logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId))+                return $ InL semanticTokens++-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.+--+-- This Rule collects information from various sources, including:+--+-- Imported name token type from Rule 'GetDocMap'+-- Local names token type from 'hieAst'+-- Name locations from 'hieAst'+-- Visible names from 'tmrRenamed'++--+-- It then combines this information to compute the semantic tokens for the file.+getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()+getSemanticTokensRule recorder =+  define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do+    (HAR {..}) <- lift $ use_ GetHieAst nfp+    (DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp+    ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp+    virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp+    let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap+    return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast+++-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs++-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)+handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)+handleError recorder action' = do+  valueEither <- runExceptT action'+  case valueEither of+    Left msg -> do+      logWith recorder Warning msg+      pure $ toIdeResult (Left [])+    Right value -> pure $ toIdeResult (Right value)++-----------------------+-- helper functions+-----------------------++-- keep track of the semantic tokens response id+-- so that we can compute the delta between two versions+getAndIncreaseSemanticTokensId :: Action SemanticTokenId+getAndIncreaseSemanticTokensId = do+  ShakeExtras{semanticTokensId} <- getShakeExtras+  liftIO $ atomically $ do+    i <- stateTVar semanticTokensId (\val -> (val, val+1))+    return $ T.pack $ show i++getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens)+getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache++setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action ()+setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+++-- |+-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:+--+-- 1. Mapping semantic token type to and from the LSP default token type.+-- 2. Mapping from GHC type and tyThing to semantic token type.+-- 3. Mapping from hieAst identifier details to haskell semantic token type.+-- 4. Mapping from LSP tokens to SemanticTokenOriginal.+module Ide.Plugin.SemanticTokens.Mappings where++import qualified Data.Array                      as A+import           Data.List.Extra                 (chunksOf, (!?))+import qualified Data.Map.Strict                 as Map+import           Data.Maybe                      (mapMaybe)+import qualified Data.Set                        as Set+import           Data.Text                       (Text, unpack)+import           Development.IDE                 (HieKind (HieFresh, HieFromDisk))+import           Development.IDE.GHC.Compat+import           Ide.Plugin.SemanticTokens.Types+import           Ide.Plugin.SemanticTokens.Utils (mkRange)+import           Language.LSP.Protocol.Types     (LspEnum (knownValues),+                                                  SemanticTokenAbsolute (SemanticTokenAbsolute),+                                                  SemanticTokenRelative (SemanticTokenRelative),+                                                  SemanticTokenTypes (..),+                                                  SemanticTokens (SemanticTokens),+                                                  UInt, absolutizeTokens)+import           Language.LSP.VFS                hiding (line)++-- * 0. Mapping name to Hs semantic token type.++nameInfixOperator :: Name -> Maybe HsSemanticTokenType+nameInfixOperator name | isSymOcc (nameOccName name) = Just TOperator+nameInfixOperator _ = Nothing++-- * 1. Mapping semantic token type to and from the LSP default token type.++-- | map from haskell semantic token type to LSP default token type+toLspTokenType :: SemanticTokensConfig  -> HsSemanticTokenType -> SemanticTokenTypes+toLspTokenType conf tk = case tk of+  TFunction        -> stFunction conf+  TVariable        -> stVariable conf+  TClassMethod     -> stClassMethod conf+  TTypeVariable    -> stTypeVariable conf+  TDataConstructor -> stDataConstructor conf+  TClass           -> stClass conf+  TTypeConstructor -> stTypeConstructor conf+  TTypeSynonym     -> stTypeSynonym conf+  TTypeFamily      -> stTypeFamily conf+  TRecordField     -> stRecordField conf+  TPatternSynonym  -> stPatternSynonym conf+  TModule          -> stModule conf+  TOperator        -> stOperator conf++lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType+lspTokenReverseMap config+    | length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"+    | otherwise = mr+    where xs = enumFrom minBound+          mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs++lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType+lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)++-- * 2. Mapping from GHC type and tyThing to semantic token type.++-- | tyThingSemantic+tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType+tyThingSemantic ty | (Just hst) <- tyThingSemantic' ty = Just hst <> nameInfixOperator (getName ty)+tyThingSemantic _ = Nothing+tyThingSemantic' :: TyThing -> Maybe HsSemanticTokenType+tyThingSemantic' ty = case ty of+  AnId vid+    | isTyVar vid -> Just TTypeVariable+    | isRecordSelector vid -> Just TRecordField+    | isClassOpId vid -> Just TClassMethod+    | isFunVar vid -> Just TFunction+    | otherwise -> Just TVariable+  AConLike con -> case con of+    RealDataCon _ -> Just TDataConstructor+    PatSynCon _   -> Just TPatternSynonym+  ATyCon tyCon+    | isTypeSynonymTyCon tyCon -> Just TTypeSynonym+    | isTypeFamilyTyCon tyCon -> Just TTypeFamily+    | isClassTyCon tyCon -> Just TClass+    -- fall back to TTypeConstructor the result+    | otherwise -> Just TTypeConstructor+  ACoAxiom _ -> Nothing+  where+    isFunVar :: Var -> Bool+    isFunVar var = isFunType $ varType var++-- expand the type synonym https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Core.Type.html+expandTypeSyn :: Type -> Type+expandTypeSyn ty+  | Just ty' <- coreView ty = expandTypeSyn ty'+  | otherwise               = ty++isFunType :: Type -> Bool+isFunType a = case expandTypeSyn a of+  ForAllTy _ t    -> isFunType t+  --   Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish+  --   (->, =>, etc..)+  FunTy flg _ rhs -> isVisibleFunArg flg || isFunType rhs+  _x              -> isFunTy a+++hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a+hieKindFunMasksKind hieKind = case hieKind of+  HieFresh -> HieFreshFun+  HieFromDisk full_file -> HieFromDiskFun $ recoverFunMaskArray (hie_types full_file)++-- wz1000 offered+-- the idea from https://gitlab.haskell.org/ghc/haddock/-/blob/b0b0e0366457c9aefebcc94df74e5de4d00e17b7/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs#L107+-- optimize version of looking for which types are functions without unfolding the whole type+recoverFunMaskArray ::+  -- | flat types+  A.Array TypeIndex HieTypeFlat ->+  -- | array of bool indicating whether the type is a function+  A.Array TypeIndex Bool+recoverFunMaskArray flattened = unflattened+  where+    -- The recursion in 'unflattened' is crucial - it's what gives us sharing+    -- function indicator check.+    unflattened :: A.Array TypeIndex Bool+    unflattened = fmap (go . fmap (unflattened A.!)) flattened++    -- Unfold an 'HieType' whose sub-terms have already been unfolded+    go :: HieType Bool -> Bool+    go (HTyVarTy _name)              = False+    go (HAppTy _f _x)                = False+    go (HLitTy _lit)                 = False+    go (HForAllTy ((_n, _k), _af) b) = b+    go (HFunTy {})                   = True+    go (HQualTy _constraint b)       = b+    go (HCastTy b)                   = b+    go HCoercionTy                   = False+    -- we have no enough information to expand the type synonym+    go (HTyConApp _ _)               = False++typeSemantic :: HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType+typeSemantic kind t = case kind of+  HieFreshFun        -> if isFunType t then Just TFunction else Nothing+  HieFromDiskFun arr -> if arr A.! t then Just TFunction else Nothing++-- * 3. Mapping from hieAst ContextInfo to haskell semantic token type.++infoTokenType :: ContextInfo -> Maybe HsSemanticTokenType+infoTokenType x = case x of+  Use                      -> Nothing+  MatchBind                -> Nothing+  IEThing _                -> Nothing+  TyDecl                   -> Nothing -- type signature+  ValBind RegularBind _ _  -> Just TVariable+  ValBind InstanceBind _ _ -> Just TClassMethod+  PatternBind {}           -> Just TVariable+  ClassTyDecl _            -> Just TClassMethod+  TyVarBind _ _            -> Just TTypeVariable+  RecField _ _             -> Just TRecordField+  -- data constructor, type constructor, type synonym, type family+  Decl ClassDec _          -> Just TClass+  Decl DataDec _           -> Just TTypeConstructor+  Decl ConDec _            -> Just TDataConstructor+  Decl SynDec _            -> Just TTypeSynonym+  Decl FamDec _            -> Just TTypeFamily+  -- instance dec is class method+  Decl InstDec _           -> Just TClassMethod+  Decl PatSynDec _         -> Just TPatternSynonym+  EvidenceVarUse           -> Nothing+  EvidenceVarBind {}       -> Nothing++-- * 4. Mapping from LSP tokens to SemanticTokenOriginal.++-- | recoverSemanticTokens+-- for debug and test.+-- this function is used to recover the original tokens(with token in haskell token type zoon)+-- from the lsp semantic tokens(with token in lsp token type zoon)+-- the `SemanticTokensConfig` used should be a map with bijection property+recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]+recoverSemanticTokens config v s = do+    tks <- recoverLspSemanticTokens v s+    return $ map (lspTokenHsToken config) tks++-- | lspTokenHsToken+-- for debug and test.+-- use the `SemanticTokensConfig` to convert lsp token type to haskell token type+-- the `SemanticTokensConfig` used should be a map with bijection property+lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType+lspTokenHsToken config (SemanticTokenOriginal tokenType location name) =+        case lspTokenTypeHsTokenType config tokenType of+        Just t  -> SemanticTokenOriginal t location name+        Nothing -> error "recoverSemanticTokens: unknown lsp token type"++-- | recoverLspSemanticTokens+-- for debug and test.+-- this function is used to recover the original tokens(with token in standard lsp token type zoon)+-- from the lsp semantic tokens(with token in lsp token type zoon)+recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes]+recoverLspSemanticTokens vsf (SemanticTokens _ xs) = do+  tokens <- dataActualToken xs+  return $ mapMaybe (tokenOrigin sourceCode) tokens+  where+    sourceCode = unpack $ virtualFileText vsf+    tokenOrigin :: [Char] -> SemanticTokenAbsolute -> Maybe (SemanticTokenOriginal SemanticTokenTypes)+    tokenOrigin sourceCode' (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) = do+      -- convert back to count from 1+      let range = mkRange line startChar len+      CodePointRange (CodePointPosition x y) (CodePointPosition _ y1) <- rangeToCodePointRange vsf range+      let line' = x+      let startChar' = y+      let len' = y1 - y+      let tLine = lines sourceCode' !? fromIntegral line'+      let name = maybe "no source" (take (fromIntegral len') . drop (fromIntegral startChar')) tLine+      return $ SemanticTokenOriginal tokenType (Loc (line' + 1) (startChar' + 1) len') name++    dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute]+    dataActualToken dt =+      maybe decodeError (Right . absolutizeTokens) $+        mapM fromTuple (chunksOf 5 $ map fromIntegral dt)+      where+        decodeError = Left "recoverSemanticTokenRelative: wrong token data"+        fromTuple [a, b, c, d, _] = SemanticTokenRelative a b c <$> fromInt (fromIntegral d) <*> return []+        fromTuple _ = Nothing+++    -- legends :: SemanticTokensLegend+    fromInt :: Int -> Maybe SemanticTokenTypes+    fromInt i = Set.toAscList knownValues !? i++-- Note [Semantic information from Multiple Sources]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We group Name into 2 categories since the information source is different:+-- 1. Locally defined Name+-- Information source is current module's HieAst,+-- Either from ContextInfo(all except differing function and none-function)+-- or from Hie Type(Differing Function and Non-function Variable)+-- 2. Imported Name+-- Information source is `TyThing` for the `Name`, looked up in `HscEnv`(with all imported things loaded).+-- `TyThing` is information rich, since it is used to represent the things that a name can refer to in ghc.+-- The reason why we need special handling for imported name is that+-- Up to 9.8+-- 1. For Hie Type, IfaceTyCon in hie type does not contain enough information to distinguish class, type syn, type family etc..+-- 2. Most imported name is only annotated as [Use] in the ContextInfo from hie.+-- 3. `namespace` in `Name` is limited, we can only classify `VarName, FldName, DataName, TvNamem, TcClsName`.+-- 4. WiredIn `Name` have `TyThing` attached, but not many are WiredIn names.
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs view
@@ -0,0 +1,92 @@+-- |+-- The query module is used to query the semantic tokens from the AST+module Ide.Plugin.SemanticTokens.Query where++import           Control.Applicative                  ((<|>))+import           Data.Foldable                        (fold)+import qualified Data.Map.Strict                      as M+import           Data.Maybe                           (listToMaybe, mapMaybe)+import qualified Data.Set                             as Set+import           Data.Text                            (Text)+import           Development.IDE.Core.PositionMapping (PositionMapping,+                                                       toCurrentRange)+import           Development.IDE.GHC.Compat+import           Ide.Plugin.SemanticTokens.Mappings+import           Ide.Plugin.SemanticTokens.Types      (HieFunMaskKind,+                                                       HsSemanticTokenType (TModule),+                                                       RangeSemanticTokenTypeList,+                                                       SemanticTokenId,+                                                       SemanticTokensConfig)+import           Language.LSP.Protocol.Types          (Position (Position),+                                                       Range (Range),+                                                       SemanticTokenAbsolute (SemanticTokenAbsolute),+                                                       SemanticTokens (SemanticTokens),+                                                       SemanticTokensDelta (SemanticTokensDelta),+                                                       defaultSemanticTokensLegend,+                                                       makeSemanticTokens,+                                                       makeSemanticTokensDelta)+import           Prelude                              hiding (length, span)++---------------------------------------------------------++-- * extract semantic++---------------------------------------------------------++idSemantic :: forall a. NameEnv TyThing -> HieFunMaskKind a -> RefMap a -> Identifier -> Maybe HsSemanticTokenType+idSemantic _ _ _ (Left _) = Just TModule+idSemantic tyThingMap hieKind rm (Right n) =+    nameSemanticFromHie hieKind rm n -- local name+    <|> (lookupNameEnv tyThingMap n >>= tyThingSemantic) -- global name+++---------------------------------------------------------++-- * extract semantic from HieAst for local variables++---------------------------------------------------------++nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType+nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n)+  where+    idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType+    idSemanticFromRefMap rm' name' = do+      spanInfos <- M.lookup name' rm'+      let typeTokenType = foldMap (typeSemantic hieKind) $ listToMaybe $ mapMaybe (identType . snd) spanInfos+      contextInfoTokenType <- foldMap (contextInfosMaybeTokenType . identInfo . snd) spanInfos+      fold [typeTokenType, Just contextInfoTokenType, nameInfixOperator n]++    contextInfosMaybeTokenType :: Set.Set ContextInfo -> Maybe HsSemanticTokenType+    contextInfosMaybeTokenType details = foldMap infoTokenType (Set.toList details)+++-------------------------------------------------++-- * extract lsp semantic tokens from RangeSemanticTokenTypeList++-------------------------------------------------++rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens+rangeSemanticsSemanticTokens sid stc mapping =+  makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)+  where+    toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute+    toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =+      let len = endColumn - startColumn+       in SemanticTokenAbsolute+            (fromIntegral startLine)+            (fromIntegral startColumn)+            (fromIntegral len)+            (toLspTokenType stc tokenType)+            []++makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens+makeSemanticTokensWithId sid tokens = do+    (SemanticTokens _  tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens+    return $ SemanticTokens sid tokens++makeSemanticTokensDeltaWithId :: Maybe SemanticTokenId ->  SemanticTokens -> SemanticTokens -> SemanticTokensDelta+makeSemanticTokensDeltaWithId sid previousTokens currentTokens =+    let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens+    in SemanticTokensDelta sid stEdits+
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies          #-}++module Ide.Plugin.SemanticTokens.SemanticConfig where++import           Data.Char                       (toLower)+import           Data.Default                    (def)+import qualified Data.Set                        as S+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Development.IDE                 (Action, usePropertyAction)+import           GHC.TypeLits                    (KnownSymbol)+import           Ide.Plugin.Properties           (KeyNameProxy, NotElem,+                                                  Properties,+                                                  PropertyKey (type PropertyKey),+                                                  PropertyType (type TEnum),+                                                  defineEnumProperty,+                                                  emptyProperties)+import           Ide.Plugin.SemanticTokens.Types+import           Ide.Types                       (PluginId)+import           Language.Haskell.TH+import           Language.LSP.Protocol.Types     (LspEnum (..),+                                                  SemanticTokenTypes)++docName :: HsSemanticTokenType -> T.Text+docName tt = case tt of+  TVariable        -> "variables"+  TFunction        -> "functions"+  TDataConstructor -> "data constructors"+  TTypeVariable    -> "type variables"+  TClassMethod     -> "typeclass methods"+  TPatternSynonym  -> "pattern synonyms"+  TTypeConstructor -> "type constructors"+  TClass           -> "typeclasses"+  TTypeSynonym     -> "type synonyms"+  TTypeFamily      -> "type families"+  TRecordField     -> "record fields"+  TModule          -> "modules"+  TOperator        -> "operators"++toConfigName :: String -> String+toConfigName = ("st" <>)++type LspTokenTypeDescriptions = [(SemanticTokenTypes, T.Text)]++lspTokenTypeDescriptions :: LspTokenTypeDescriptions+lspTokenTypeDescriptions =+  map+    ( \x ->+        (x, "LSP Semantic Token Type: " <> toEnumBaseType x)+    )+    $ S.toList knownValues++allHsTokenTypes :: [HsSemanticTokenType]+allHsTokenTypes = enumFrom minBound++lowerFirst :: String -> String+lowerFirst []       = []+lowerFirst (x : xs) = toLower x : xs++allHsTokenNameStrings :: [String]+allHsTokenNameStrings = map (drop 1 . show) allHsTokenTypes++defineSemanticProperty ::+  (NotElem s r, KnownSymbol s) =>+  (KeyNameProxy s, Text, SemanticTokenTypes) ->+  Properties r ->+  Properties ('PropertyKey s (TEnum SemanticTokenTypes) : r)+defineSemanticProperty (lb, tokenType, st) =+  defineEnumProperty+    lb+    tokenType+    lspTokenTypeDescriptions+    st++semanticDef :: SemanticTokensConfig+semanticDef = def++-- | it produces the following functions:+-- semanticConfigProperties :: Properties '[+-- 'PropertyKey "Variable" ('TEnum SemanticTokenTypes),+-- ...+-- ]+-- useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig+mkSemanticConfigFunctions :: Q [Dec]+mkSemanticConfigFunctions = do+  let pid = mkName "pid"+  let semanticConfigPropertiesName = mkName "semanticConfigProperties"+  let useSemanticConfigActionName = mkName "useSemanticConfigAction"+  let allLabelStrs = map ((<> "Token") . lowerFirst) allHsTokenNameStrings+      allLabels = map (LabelE . (<> "Token") . lowerFirst) allHsTokenNameStrings+      allFieldsNames = map (mkName . toConfigName) allHsTokenNameStrings+      allVariableNames = map (mkName . ("_variable_" <>) . toConfigName) allHsTokenNameStrings+      --   <- useSemanticConfigAction label pid config+      mkGetProperty (variable, label) =+        BindS+          (VarP variable)+          (AppE (VarE 'usePropertyAction) label `AppE` VarE pid `AppE` VarE semanticConfigPropertiesName)+      getProperties = zipWith (curry mkGetProperty) allVariableNames allLabels+      recordUpdate =+        RecUpdE (VarE 'semanticDef) $+          zipWith (\fieldName variableName -> (fieldName, VarE variableName)) allFieldsNames allVariableNames+      -- get and then update record+      bb = DoE Nothing $ getProperties ++ [NoBindS $ AppE (VarE 'return) recordUpdate]+  let useSemanticConfigAction = FunD useSemanticConfigActionName [Clause [VarP pid] (NormalB bb) []]+  let useSemanticConfigActionSig = SigD useSemanticConfigActionName (ArrowT `AppT` ConT ''PluginId `AppT` (ConT ''Action `AppT` ConT ''SemanticTokensConfig))++  -- SemanticConfigProperties+  nameAndDescList <-+    mapM+      ( \(lb, x) -> do+          desc <- [|"LSP semantic token type to use for " <> docName x|]+          lspToken <- [|toLspTokenType def x|]+          return $ TupE [Just lb, Just desc, Just lspToken]+      )+      $ zip allLabels allHsTokenTypes+  let body = foldr (AppE . AppE (VarE 'defineSemanticProperty)) (VarE 'emptyProperties) nameAndDescList+  let propertiesType =+        foldr+          ( \la ->+              AppT+                ( PromotedConsT+                    `AppT` (AppT (ConT 'PropertyKey) (LitT (StrTyLit la)) `AppT` AppT (ConT 'TEnum) (ConT ''SemanticTokenTypes))+                )+          )+          PromotedNilT+          allLabelStrs+  let semanticConfigProperties = FunD semanticConfigPropertiesName [Clause [] (NormalB body) []]+  let semanticConfigPropertiesSig = SigD semanticConfigPropertiesName (AppT (ConT ''Properties) propertiesType)+  return [semanticConfigPropertiesSig, semanticConfigProperties, useSemanticConfigActionSig, useSemanticConfigAction]
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings   #-}++module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where++import           Control.Lens                     (Identity (runIdentity))+import           Control.Monad                    (foldM, guard)+import           Control.Monad.State.Strict       (MonadState (get),+                                                   MonadTrans (lift),+                                                   evalStateT, modify, put)+import           Control.Monad.Trans.State.Strict (StateT, runStateT)+import           Data.Char                        (isAlphaNum)+import           Data.DList                       (DList)+import qualified Data.DList                       as DL+import qualified Data.Map.Strict                  as M+import qualified Data.Map.Strict                  as Map+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import qualified Data.Text.Rope                   as Char+import qualified Data.Text.Utf16.Rope             as Utf16+import           Data.Text.Utf16.Rope.Mixed       (Rope)+import qualified Data.Text.Utf16.Rope.Mixed       as Rope+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Error        (realSrcSpanToCodePointRange)+import           Ide.Plugin.SemanticTokens.Types  (HsSemanticTokenType (TModule),+                                                   RangeHsSemanticTokenTypes (..))+import           Language.LSP.Protocol.Types      (Position (Position),+                                                   Range (Range), UInt, mkRange)+import           Language.LSP.VFS                 hiding (line)+import           Prelude                          hiding (length, span)++type Tokenizer m a = StateT PTokenState m a+type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType+++data PTokenState = PTokenState+  {+    rope             :: !Rope -- the remains of rope we are working on+    , cursor         :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position+    , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16+  }++data SplitResult+  = NoSplit (Text, Range) -- does not need to split, token text, token range+  | Split (Text, Range, Range) -- token text, prefix range(module range), token range+  deriving (Show)++getSplitTokenText :: SplitResult -> Text+getSplitTokenText (NoSplit (t, _))  = t+getSplitTokenText (Split (t, _, _)) = t+++mkPTokenState :: VirtualFile -> PTokenState+mkPTokenState vf =+  PTokenState+    {+      rope = vf._file_text,+      cursor = Char.Position 0 0,+      columnsInUtf16 = 0+    }++-- lift a Tokenizer Maybe a to Tokenizer m a,+-- if the Maybe is Nothing, do nothing, recover the state, and return the mempty value+-- if the Maybe is Just x, do the action, and keep the state, and return x+liftMaybeM :: (Monad m, Monoid a) => Tokenizer Maybe a -> Tokenizer m a+liftMaybeM p = do+  st <- get+  maybe (return mempty) (\(ans, st') -> put st' >> return ans) $ runStateT p st++foldMapM :: (Monad m, Monoid b, Foldable t) => (a -> m b) -> t a -> m b+foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta++computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes+computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast =+    RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf)+-- | foldAst+-- visit every leaf node in the ast in depth first order+foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))+foldAst lookupHsTokenType ast = if null (nodeChildren ast)+  then liftMaybeM (visitLeafIds lookupHsTokenType ast)+  else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast++visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))+visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do+  let span = nodeSpan leaf+  (ran, token) <- focusTokenAt leaf+  -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly+  -- we do not need to recover the cursor state, even if the following computation failed+  liftMaybeM $ do+    -- only handle the leaf node with single column token+    guard $ srcSpanStartLine span == srcSpanEndLine span+    splitResult <- lift $ splitRangeByText token ran+    foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf+  where+    combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType))+    combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) =+        case (maybeTokenType, ranSplit) of+            (Nothing, _) -> return mempty+            (Just TModule, _) -> return $ DL.singleton (ran, TModule)+            (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType)+            (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)]+        where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd)++    getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType+    getIdentifier lookupHsTokenType ranSplit idt = do+      case idt of+        Left _moduleName -> Just TModule+        Right name -> do+          occStr <- T.pack <$> case (occNameString . nameOccName) name of+            -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-}+            '$' : 's' : 'e' : 'l' : ':' : xs -> Just $ takeWhile (/= ':') xs+            -- other generated names that should not be visible+            '$' : c : _ | isAlphaNum c       -> Nothing+            c : ':' : _ | isAlphaNum c       -> Nothing+            ns                               -> Just ns+          guard $ getSplitTokenText ranSplit == occStr+          lookupHsTokenType idt+++focusTokenAt ::+  -- | leaf node we want to focus on+  HieAST a ->+  -- | (token, remains)+  Tokenizer Maybe (Range, Text)+focusTokenAt leaf = do+  PTokenState{cursor, rope, columnsInUtf16} <- get+  let span = nodeSpan leaf+  let (tokenStartPos, tokenEndPos) = srcSpanCharPositions span+  -- tokenStartOff: the offset position of the token start position to the cursor position+  tokenStartOff <- lift $ tokenStartPos `sub` cursor+  -- tokenOff: the offset position of the token end position to the token start position+  tokenOff <- lift $ tokenEndPos `sub` tokenStartPos+  (gap, tokenStartRope) <- lift $ charSplitAtPositionMaybe tokenStartOff rope+  (token, remains) <- lift $ charSplitAtPositionMaybe tokenOff tokenStartRope+  -- ncs: token start column in utf16+  let ncs = newColumn columnsInUtf16 gap+  -- nce: token end column in utf16+  let nce = newColumn ncs token+  -- compute the new range for utf16, tuning the columns is enough+  let ran = codePointRangeToRangeWith ncs nce $ realSrcSpanToCodePointRange span+  modify $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos}+  return (ran, token)+  where+    srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position)+    srcSpanCharPositions real =+        ( realSrcLocRopePosition $ realSrcSpanStart real,+          realSrcLocRopePosition $ realSrcSpanEnd real+        )+    charSplitAtPositionMaybe :: Char.Position -> Rope -> Maybe (Text, Rope)+    charSplitAtPositionMaybe tokenOff rpe = do+      let (prefix, suffix) = Rope.charSplitAtPosition tokenOff rpe+      guard $ Rope.charLengthAsPosition prefix == tokenOff+      return (Rope.toText prefix, suffix)+    sub :: Char.Position -> Char.Position -> Maybe Char.Position+    sub (Char.Position l1 c1) (Char.Position l2 c2)+      | l1 == l2 && c1 >= c2 = Just $ Char.Position 0 (c1 - c2)+      | l1 > l2 = Just $ Char.Position (l1 - l2) c1+      | otherwise = Nothing+    realSrcLocRopePosition :: RealSrcLoc -> Char.Position+    realSrcLocRopePosition real = Char.Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1)+    -- | newColumn+    -- rope do not treat single \n in our favor+    -- for example, the row length of "123\n" and "123" are both 1+    -- we are forced to use text to compute new column+    newColumn :: UInt -> Text -> UInt+    newColumn n rp = case T.breakOnEnd "\n" rp of+      ("", nEnd) -> n + utf16Length nEnd+      (_, nEnd)  -> utf16Length nEnd+    codePointRangeToRangeWith :: UInt -> UInt -> CodePointRange -> Range+    codePointRangeToRangeWith newStartCol newEndCol (CodePointRange (CodePointPosition startLine _) (CodePointPosition endLine _)) =+      Range (Position startLine newStartCol) (Position endLine newEndCol)++-- | splitRangeByText+-- split a qualified identifier into module name and identifier and/or strip the (), ``+-- for `ModuleA.b`, break it into `ModuleA.` and `b`+-- for `(b)`, strip `()`, and get `b`+-- for `(ModuleA.b)`, strip `()` and break it into `ModuleA.` and `b`+splitRangeByText :: Text -> Range -> Maybe SplitResult+splitRangeByText tk ran = do+  let (ran', tk') = case T.uncons tk of+        Just ('(', xs) -> (subOneRange ran, T.takeWhile (/= ')') xs)+        Just ('`', xs) -> (subOneRange ran, T.takeWhile (/= '`') xs)+        _              -> (ran, tk)+  let (prefix, tk'') = T.breakOnEnd "." tk'+  splitRange tk'' (utf16PositionPosition $ Rope.utf16LengthAsPosition $ Rope.fromText prefix) ran'+  where+    splitRange :: Text -> Position -> Range -> Maybe SplitResult+    splitRange tx (Position l c) r@(Range (Position l1 c1) (Position l2 c2))+      | l1 + l > l2 || (l1 + l == l2 && c > c2) = Nothing -- out of range+      | l==0 && c==0 = Just $ NoSplit (tx, r)+      | otherwise = let c' = if l <= 0 then c1+c else c+                    in Just $ Split (tx, mkRange l1 c1 (l1 + l) c', mkRange (l1 + l) c' l2 c2)+    subOneRange :: Range -> Range+    subOneRange (Range (Position l1 c1) (Position l2 c2)) = Range (Position l1 (c1 + 1)) (Position l2 (c2 - 1))+    utf16PositionPosition :: Utf16.Position -> Position+    utf16PositionPosition (Utf16.Position l c) = Position (fromIntegral l) (fromIntegral c)+++utf16Length :: Integral i => Text -> i+utf16Length = fromIntegral . Utf16.length . Utf16.fromText
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DerivingVia       #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData        #-}+{-# LANGUAGE TypeFamilies      #-}++module Ide.Plugin.SemanticTokens.Types where++import           Control.DeepSeq               (NFData (rnf), rwhnf)+import qualified Data.Array                    as A+import           Data.Default                  (Default (def))+import           Data.Generics                 (Typeable)+import           Development.IDE               (Pretty (pretty), RuleResult)+import qualified Development.IDE.Core.Shake    as Shake+import           Development.IDE.GHC.Compat    hiding (loc)+import           Development.IDE.Graph.Classes (Hashable)+import           GHC.Generics                  (Generic)+import           Language.LSP.Protocol.Types+-- import template haskell+import           Data.Text                     (Text)+import           Language.Haskell.TH.Syntax    (Lift)+++-- !!!! order of declarations matters deriving enum and ord+-- since token may come from different source and we want to keep the most specific one+-- and we might want to merge them.+data HsSemanticTokenType+  = TVariable -- none function variable+  | TFunction -- function+  | TDataConstructor -- Data constructor+  | TTypeVariable -- Type variable+  | TClassMethod -- Class method+  | TPatternSynonym -- Pattern synonym+  | TTypeConstructor -- Type (Type constructor)+  | TClass -- Type class+  | TTypeSynonym -- Type synonym+  | TTypeFamily -- type family+  | TRecordField -- from match bind+  | TOperator-- operator+  | TModule -- module name+  deriving (Eq, Ord, Show, Enum, Bounded, Generic, Lift)++-- type SemanticTokensConfig = SemanticTokensConfig_ Identity+instance Default SemanticTokensConfig where+  def = STC+      { stFunction = SemanticTokenTypes_Function+      , stVariable = SemanticTokenTypes_Variable+      , stDataConstructor = SemanticTokenTypes_EnumMember+      , stTypeVariable = SemanticTokenTypes_TypeParameter+      , stClassMethod = SemanticTokenTypes_Method+      -- pattern syn is like a limited version of macro of constructing a term+      , stPatternSynonym = SemanticTokenTypes_Macro+        -- normal data type is a tagged union type look like enum type+        -- and a record is a product type like struct+        -- but we don't distinguish them yet+      , stTypeConstructor = SemanticTokenTypes_Enum+      , stClass = SemanticTokenTypes_Class+      , stTypeSynonym = SemanticTokenTypes_Type+      , stTypeFamily = SemanticTokenTypes_Interface+      , stRecordField = SemanticTokenTypes_Property+      , stModule = SemanticTokenTypes_Namespace+      , stOperator = SemanticTokenTypes_Operator+      }+-- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin.+-- it contains map between the hs semantic token type and default token type.+data SemanticTokensConfig = STC+  { stFunction        :: !SemanticTokenTypes+  , stVariable        :: !SemanticTokenTypes+  , stDataConstructor :: !SemanticTokenTypes+  , stTypeVariable    :: !SemanticTokenTypes+  , stClassMethod     :: !SemanticTokenTypes+  , stPatternSynonym  :: !SemanticTokenTypes+  , stTypeConstructor :: !SemanticTokenTypes+  , stClass           :: !SemanticTokenTypes+  , stTypeSynonym     :: !SemanticTokenTypes+  , stTypeFamily      :: !SemanticTokenTypes+  , stRecordField     :: !SemanticTokenTypes+  , stModule          :: !SemanticTokenTypes+  , stOperator        :: !SemanticTokenTypes+  } deriving (Generic, Show)+++instance Semigroup HsSemanticTokenType where+  -- one in higher enum is more specific+  a <> b = max a b++data SemanticTokenOriginal tokenType = SemanticTokenOriginal+  { _tokenType :: tokenType,+    _loc       :: Loc,+    _name      :: String+  }+  deriving (Eq, Ord)++--+instance (Show tokenType) => Show (SemanticTokenOriginal tokenType) where+  show (SemanticTokenOriginal tk loc name) = show loc <> " " <> show tk <> " " <> show name++data Loc = Loc+  { _line      :: UInt,+    _startChar :: UInt,+    _len       :: UInt+  }+  deriving (Eq, Ord)++instance Show Loc where+  show (Loc line startChar len) = show line <> ":" <> show startChar <> "-" <> show (startChar + len)++data GetSemanticTokens = GetSemanticTokens+  deriving (Eq, Show, Typeable, Generic)++instance Hashable GetSemanticTokens++instance NFData GetSemanticTokens++type RangeSemanticTokenTypeList = [(Range, HsSemanticTokenType)]++newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticList :: RangeSemanticTokenTypeList}++instance NFData RangeHsSemanticTokenTypes where+  rnf :: RangeHsSemanticTokenTypes -> ()+  rnf (RangeHsSemanticTokenTypes a) = rwhnf a++instance Show RangeHsSemanticTokenTypes where+  show (RangeHsSemanticTokenTypes xs) = unlines $ map showRangeToken xs++showRangeToken :: (Range, HsSemanticTokenType) -> String+showRangeToken (ran, tk) = showRange ran <> " " <> show tk+showRange :: Range -> String+showRange (Range (Position l1 c1) (Position l2 c2)) = show l1 <> ":" <> show c1 <> "-" <> show l2 <> ":" <> show c2++type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes++data HieFunMaskKind kind where+  HieFreshFun :: HieFunMaskKind Type+  HieFromDiskFun :: A.Array TypeIndex Bool -> HieFunMaskKind TypeIndex++data SemanticLog+  = LogShake Shake.Log+  | LogNoAST FilePath+  | LogConfig SemanticTokensConfig+  | LogMsg String+  | LogNoVF+  | LogSemanticTokensDeltaMisMatch Text (Maybe Text)+  deriving (Show)++instance Pretty SemanticLog where+  pretty theLog = case theLog of+    LogShake shakeLog -> pretty shakeLog+    LogNoAST path     -> "no HieAst exist for file" <> pretty path+    LogNoVF           -> "no VirtualSourceFile exist for file"+    LogConfig config  -> "SemanticTokensConfig_: " <> pretty (show config)+    LogMsg msg        -> "SemanticLog Debug Message: " <> pretty msg+    LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache+                      -> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest+                      <> " previousIdFromCache: " <> pretty previousIdFromCache+++type SemanticTokenId = Text
+ plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -Wno-orphans #-}+++module Ide.Plugin.SemanticTokens.Utils where++import           Data.ByteString            (ByteString)+import           Data.ByteString.Char8      (unpack)+import qualified Data.Map.Strict            as Map+import           Development.IDE            (Position (..), Range (..))+import           Development.IDE.GHC.Compat+import           Prelude                    hiding (length, span)++deriving instance Show DeclType+deriving instance Show BindType+deriving instance Show RecFieldContext++instance Show ContextInfo where+    show x = case x of+        Use                -> "Use"+        MatchBind          -> "MatchBind"+        IEThing _          -> "IEThing IEType" -- imported+        TyDecl             -> "TyDecl"+        ValBind bt _ sp    -> "ValBind of " <> show bt <> show sp+        PatternBind {}     -> "PatternBind"+        ClassTyDecl _      -> "ClassTyDecl"+        Decl d _           -> "Decl of " <> show d+        TyVarBind _ _      -> "TyVarBind"+        RecField c _       -> "RecField of " <> show c+        EvidenceVarBind {} -> "EvidenceVarBind"+        EvidenceVarUse     -> "EvidenceVarUse"++showCompactRealSrc :: RealSrcSpan -> String+showCompactRealSrc x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x)++-- type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]+showRefMap :: RefMap a -> String+showRefMap m = unlines+    [+       showIdentifier idn ++ ":"+       ++ "\n" ++ unlines [showSDocUnsafe (ppr span) ++ "\n" ++ showIdentifierDetails v | (span, v) <- spans]+    | (idn, spans) <- Map.toList m]++showIdentifierDetails :: IdentifierDetails a -> String+showIdentifierDetails x = show $  identInfo x++showIdentifier :: Identifier -> String+showIdentifier (Left x)  = showSDocUnsafe (ppr x)+showIdentifier (Right x) = nameStableString x++showLocatedNames :: [LIdP GhcRn] -> String+showLocatedNames xs = unlines+    [ showSDocUnsafe (ppr locName) ++ " " ++ show (getLoc locName)+    | locName <- xs]++showClearName :: Name -> String+showClearName name = occNameString (occName name) <> ":" <> showSDocUnsafe (ppr name) <> ":" <> showNameType name++showName :: Name -> String+showName name = showSDocUnsafe (ppr name) <> ":" <> showNameType name++showNameType :: Name -> String+showNameType name+    | isWiredInName name  = "WiredInName"+    | isSystemName name   = "SystemName"+    | isInternalName name = "InternalName"+    | isExternalName name = "ExternalName"+    | otherwise           = "UnknownName"++bytestringString :: ByteString -> String+bytestringString = map (toEnum . fromEnum) . unpack++spanNamesString :: [(Span, Name)] -> String+spanNamesString xs = unlines+    [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name)+    | (span, name) <- xs]++nameTypesString :: [(Name, Type)] -> String+nameTypesString xs = unlines+    [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name)+    | (span, name) <- xs]+++showSpan :: RealSrcSpan -> String+showSpan x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x)+++-- rangeToCodePointRange+mkRange :: (Integral a1, Integral a2) => a1 -> a2 -> a2 -> Range+mkRange startLine startCol len =+    Range (Position (fromIntegral startLine) (fromIntegral startCol)) (Position (fromIntegral startLine) (fromIntegral $ startCol + len))+++rangeShortStr :: Range -> String+rangeShortStr (Range (Position startLine startColumn) (Position endLine endColumn)) =+    show startLine <> ":" <> show startColumn <> "-" <> show endLine <> ":" <> show endColumn+
+ plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}++import           Control.Lens                       ((^.), (^?))+import           Control.Monad.IO.Class             (liftIO)+import           Data.Aeson                         (KeyValue (..), Object)+import qualified Data.Aeson.KeyMap                  as KV+import           Data.Default+import           Data.Functor                       (void)+import           Data.Map.Strict                    as Map hiding (map)+import           Data.String                        (fromString)+import           Data.Text                          hiding (length, map,+                                                     unlines)+import qualified Data.Text                          as Text+import qualified Data.Text.Utf16.Rope.Mixed         as Rope+import           Development.IDE                    (Pretty)++import           Data.Row                           ((.==))+import           Data.Row.Records                   ((.+))+import           Development.IDE.GHC.Compat         (GhcVersion (..),+                                                     ghcVersion)+import           Development.IDE.Plugin.Test        (WaitForIdeRuleResult (..))+import           Development.IDE.Test               (waitForBuildQueue)+import           Ide.Plugin.SemanticTokens+import           Ide.Plugin.SemanticTokens.Mappings+import           Ide.Plugin.SemanticTokens.Types+import           Ide.Types+import qualified Language.LSP.Protocol.Lens         as L+import           Language.LSP.Protocol.Types+import           Language.LSP.Test                  (Session,+                                                     SessionConfig (ignoreConfigurationRequests),+                                                     openDoc, request)+import qualified Language.LSP.Test                  as Test+import           Language.LSP.VFS                   (VirtualFile (..))+import           System.FilePath+import           Test.Hls                           (HasCallStack,+                                                     PluginTestDescriptor,+                                                     SMethod (SMethod_TextDocumentSemanticTokensFullDelta),+                                                     TestName, TestTree,+                                                     changeDoc,+                                                     defaultTestRunner,+                                                     documentContents, fullCaps,+                                                     goldenGitDiff,+                                                     mkPluginTestDescriptor,+                                                     pluginTestRecorder,+                                                     runSessionWithServerInTmpDir,+                                                     runSessionWithServerInTmpDir',+                                                     testCase, testGroup,+                                                     waitForAction, (@?=))+import qualified Test.Hls.FileSystem                as FS+import           Test.Hls.FileSystem                (file, text)++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-semantic-tokens-plugin" </> "test" </> "testdata"++mkFs :: [FS.FileTree] -> FS.VirtualFileTree+mkFs = FS.mkVirtualFileTree testDataDir++semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog+semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor "SemanticTokens"+  where+    enabledSemanticDescriptor recorder plId =+      let semanticDescriptor = Ide.Plugin.SemanticTokens.descriptor recorder plId+       in semanticDescriptor+            { pluginConfigDescriptor =+                (pluginConfigDescriptor semanticDescriptor)+                  { configInitialGenericConfig =+                      (configInitialGenericConfig (pluginConfigDescriptor semanticDescriptor))+                        { plcGlobalOn = True+                        }+                  }+            }++goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree+goldenWithHaskellAndCapsOutPut config plugin title tree path desc act =+  goldenGitDiff title (FS.vftOriginalRoot tree </> path <.> desc) $+    runSessionWithServerInTmpDir config plugin tree $+      fromString <$> do+        doc <- openDoc (path <.> "hs") "haskell"+        void waitForBuildQueue+        act doc++goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree+goldenWithSemanticTokensWithDefaultConfig title path =+  goldenWithHaskellAndCapsOutPut+    def+    semanticTokensPlugin+    title+    (mkFs $ FS.directProject (path <.> "hs"))+    path+    "expected"+    (docSemanticTokensString def)++docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String+docSemanticTokensString cf doc = do+  xs  <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc+  return $ unlines . map show $ xs++docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]+docLspSemanticTokensString doc = do+  res <- Test.getSemanticTokens doc+  textContent <- documentContents doc+  let vfs = VirtualFile 0 0 (Rope.fromText textContent)+  case res ^? Language.LSP.Protocol.Types._L of+    Just tokens -> do+      either (error . show) pure $ recoverLspSemanticTokens vfs tokens+    _noTokens -> error "No tokens found"+++-- | Pass a param and return the response from `semanticTokensFull`+-- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _+getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null))+getSemanticTokensFullDelta doc lastResultId = do+  let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId+  rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params+  case rsp ^. L.result of+    Right x -> return x+    _       -> error "No tokens found"+++semanticTokensClassTests :: TestTree+semanticTokensClassTests =+  testGroup+    "type class"+    [ goldenWithSemanticTokensWithDefaultConfig "golden type class" "TClass",+      goldenWithSemanticTokensWithDefaultConfig "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind",+      goldenWithSemanticTokensWithDefaultConfig "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse",+      goldenWithSemanticTokensWithDefaultConfig "imported deriving" "TClassImportedDeriving"+    ]++semanticTokensValuePatternTests :: TestTree+semanticTokensValuePatternTests =+  testGroup+    "value and patterns "+    [ goldenWithSemanticTokensWithDefaultConfig "value bind" "TValBind",+      goldenWithSemanticTokensWithDefaultConfig "pattern match" "TPatternMatch",+      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternbind"+    ]++mkSemanticConfig :: Object -> Config+mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)}+    where+      conf = def{plcConfig = setting }++++directFile :: FilePath -> Text -> [FS.FileTree]+directFile fp content =+  [ FS.directCradle [Text.pack fp]+  , file fp (text content)+  ]++semanticTokensConfigTest :: TestTree+semanticTokensConfigTest = testGroup "semantic token config test" [+        testCase "function to variable" $ do+            let content = Text.unlines ["module Hello where", "go _ = 1"]+            let fs = mkFs $ directFile "Hello.hs" content+            let funcVar = KV.fromList ["functionToken" .= var]+                var :: String+                var = "variable"+            do+                recorder <- pluginTestRecorder+                Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder)+                    (mkSemanticConfig funcVar)+                    def {ignoreConfigurationRequests = False}+                    fullCaps+                    fs $ do+                    -- modifySemantic funcVar+                    void waitForBuildQueue+                    doc <- openDoc "Hello.hs" "haskell"+                    void waitForBuildQueue+                    result1 <- docLspSemanticTokensString doc+                    liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n"+    ]++semanticTokensFullDeltaTests :: TestTree+semanticTokensFullDeltaTests =+  testGroup "semanticTokensFullDeltaTests" $+    [ testCase "null delta since unchanged" $ do+        let file1 = "TModuleA.hs"+        let expectDelta = InR (InL (SemanticTokensDelta (Just "1") []))+        Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do+          doc1 <- openDoc file1 "haskell"+          _ <- waitForAction "TypeCheck" doc1+          _ <- Test.getSemanticTokens doc1+          delta <- getSemanticTokensFullDelta doc1 "0"+          liftIO $ delta @?= expectDelta++      , testCase "add tokens" $ do+        let file1 = "TModuleA.hs"+        let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])]))+        --                                                                                         r c l t m+        --                                      where r = row, c = column, l = length, t = token, m = modifier+        Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do+          doc1 <- openDoc file1 "haskell"+          _ <- waitForAction "TypeCheck" doc1+          _ <- Test.getSemanticTokens doc1+          -- open the file and append a line to it+          let change = TextDocumentContentChangeEvent+                $ InL $ #range .== Range (Position 4 0) (Position 4 6)+                .+ #rangeLength .== Nothing+                .+ #text .== "foo = 1"+          changeDoc doc1 [change]+          _ <- waitForAction "TypeCheck" doc1+          delta <- getSemanticTokensFullDelta doc1 "0"+          liftIO $ delta @?= expectDelta++      , testCase "remove tokens" $ do+        let file1 = "TModuleA.hs"+        let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))+        -- delete all tokens+        Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do+          doc1 <- openDoc file1 "haskell"+          _ <- waitForAction "TypeCheck" doc1+          _ <- Test.getSemanticTokens doc1+          -- open the file and append a line to it+          let change = TextDocumentContentChangeEvent+                $ InL $ #range .== Range (Position 2 0) (Position 2 28)+                .+ #rangeLength .== Nothing+                .+ #text .== Text.replicate 28 " "+          changeDoc doc1 [change]+          _ <- waitForAction "TypeCheck" doc1+          delta <- getSemanticTokensFullDelta doc1 "0"+          liftIO $ delta @?= expectDelta+    ]++semanticTokensTests :: TestTree+semanticTokensTests =+  testGroup "other semantic Token test" $+    [ testCase "module import test" $ do+        let file1 = "TModuleA.hs"+        let file2 = "TModuleB.hs"+        Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1, file2]) $ do+          doc1 <- openDoc file1 "haskell"+          doc2 <- openDoc file2 "haskell"+          check1 <- waitForAction "TypeCheck" doc1+          check2 <- waitForAction "TypeCheck" doc2+          case check1 of+            Right (WaitForIdeRuleResult _) -> return ()+            Left _                         -> error "TypeCheck1 failed"+          case check2 of+            Right (WaitForIdeRuleResult _) -> return ()+            Left _                         -> error "TypeCheck2 failed"++          result <- docSemanticTokensString def doc2+          let expect = unlines [+                    "3:8-16 TModule \"TModuleA\""+                    , "4:18-26 TModule \"TModuleA\""+                    , "6:1-3 TVariable \"go\""+                    , "6:6-10 TDataConstructor \"Game\""+                    , "8:1-5 TVariable \"a\\66560bb\""+                    , "8:8-17 TModule \"TModuleA.\""+                    , "8:17-20 TRecordField \"a\\66560b\""+                    , "8:21-23 TVariable \"go\""+                ]+          liftIO $ result @?= expect,+      goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",+      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",+      goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily",+      goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax",+      goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName"+    ]+      -- not supported in ghc92+    ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92]++semanticTokensDataTypeTests :: TestTree+semanticTokensDataTypeTests =+  testGroup+    "get semantic Tokens"+    [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType",+      goldenWithSemanticTokensWithDefaultConfig "record" "TRecord",+      goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields",+      goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported",+      goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily",+      goldenWithSemanticTokensWithDefaultConfig "GADT" "TGADT"+    ]++semanticTokensFunctionTests :: TestTree+semanticTokensFunctionTests =+  testGroup+    "get semantic of functions"+    [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction",+      goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal",+      goldenWithSemanticTokensWithDefaultConfig "functions under type synonym" "TFunctionUnderTypeSynonym",+      goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet",+      goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint",+      goldenWithSemanticTokensWithDefaultConfig "TOperator" "TOperator"+    ]++main :: IO ()+main =+  defaultTestRunner $+    testGroup+      "Semantic tokens"+      [ semanticTokensTests,+        semanticTokensClassTests,+        semanticTokensDataTypeTests,+        semanticTokensValuePatternTests,+        semanticTokensFunctionTests,+        semanticTokensConfigTest,+        semanticTokensFullDeltaTests+      ]
+ plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected view
@@ -0,0 +1,81 @@+9:6-9 TTypeConstructor "Foo"+9:12-15 TDataConstructor "Foo"+9:18-21 TRecordField "foo"+9:25-28 TTypeConstructor "Int"+11:7-10 TClass "Boo"+11:11-12 TTypeVariable "a"+12:3-6 TClassMethod "boo"+12:10-11 TTypeVariable "a"+12:15-16 TTypeVariable "a"+14:10-13 TClass "Boo"+14:14-17 TTypeConstructor "Int"+15:5-8 TClassMethod "boo"+15:9-10 TVariable "x"+15:13-14 TVariable "x"+15:15-16 TOperator "+"+17:6-8 TTypeConstructor "Dd"+17:11-13 TDataConstructor "Dd"+17:14-17 TTypeConstructor "Int"+19:9-12 TPatternSynonym "One"+19:15-18 TDataConstructor "Foo"+21:1-4 TVariable "ggg"+21:7-10 TPatternSynonym "One"+23:6-9 TTypeConstructor "Doo"+23:12-15 TDataConstructor "Doo"+23:16-24 TModule "Prelude."+23:24-27 TTypeConstructor "Int"+24:6-10 TTypeSynonym "Bar1"+24:13-16 TTypeConstructor "Int"+25:6-10 TTypeSynonym "Bar2"+25:13-16 TTypeConstructor "Doo"+27:1-3 TFunction "bb"+27:8-11 TClass "Boo"+27:12-13 TTypeVariable "a"+27:18-19 TTypeVariable "a"+27:23-24 TTypeVariable "a"+28:1-3 TFunction "bb"+28:4-5 TVariable "x"+28:9-12 TClassMethod "boo"+28:13-14 TVariable "x"+29:1-3 TFunction "aa"+29:7-11 TTypeVariable "cool"+29:15-18 TTypeConstructor "Int"+29:22-26 TTypeVariable "cool"+30:1-3 TFunction "aa"+30:4-5 TVariable "x"+30:9-10 TVariable "c"+30:14-16 TFunction "aa"+30:17-18 TVariable "x"+30:19-20 TVariable "c"+31:12-14 TVariable "xx"+31:16-18 TVariable "yy"+32:11-13 TVariable "dd"+34:2-4 TVariable "zz"+34:6-8 TVariable "kk"+35:1-3 TFunction "cc"+35:7-10 TTypeConstructor "Foo"+35:15-18 TTypeConstructor "Int"+35:20-23 TTypeConstructor "Int"+35:28-31 TTypeConstructor "Int"+36:1-3 TFunction "cc"+36:4-5 TVariable "f"+36:7-9 TVariable "gg"+36:11-13 TVariable "vv"+37:10-12 TVariable "gg"+38:14-17 TRecordField "foo"+38:18-19 TOperator "$"+38:20-21 TVariable "f"+38:24-27 TRecordField "foo"+39:14-17 TRecordField "foo"+39:18-19 TOperator "$"+39:20-21 TVariable "f"+39:24-27 TRecordField "foo"+41:1-3 TFunction "go"+41:6-9 TRecordField "foo"+42:1-4 TFunction "add"+42:8-16 TModule "Prelude."+42:16-17 TOperator "+"+47:1-5 TVariable "main"+47:9-11 TTypeConstructor "IO"+48:1-5 TVariable "main"+48:8-16 TFunction "putStrLn"
+ plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs view
@@ -0,0 +1,48 @@+-- patter syn+{-# LANGUAGE PatternSynonyms #-}++module Main where++-- import Data.Set (Set, insert)+++data Foo = Foo { foo :: Int }++class Boo a where+  boo :: a -> a++instance Boo Int where+    boo x = x + 1++data Dd = Dd Int++pattern One = Foo 1++ggg = One++data Doo = Doo Prelude.Int+type Bar1 = Int+type Bar2 = Doo++bb :: (Boo a) => a -> a+bb x  = boo x+aa :: cool -> Int -> cool+aa x = \c -> aa x c+    where (xx, yy) = (1, 2)+          dd = 1++(zz, kk) = (1, 2)+cc :: Foo -> (Int, Int) -> Int+cc f (gg, vv)=+    case gg of+        1 -> foo $ f { foo = 1 }+        2 -> foo $ f { foo = 1 }++go = foo+add = (Prelude.+)++-- sub :: Int -> Int -> Int+-- sub x y = add x y++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected view
@@ -0,0 +1,5 @@+4:7-10 TClass "Foo"+4:11-12 TTypeVariable "a"+5:3-6 TClassMethod "foo"+5:10-11 TTypeVariable "a"+5:15-18 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs view
@@ -0,0 +1,6 @@+module TClass where+++class Foo a where+  foo :: a -> Int+
+ plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected view
@@ -0,0 +1,3 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:26-30 TClass "Show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE StandaloneDeriving #-}+module TClassImportedDeriving where+-- deriving method source span of Show occurrence+data Foo = Foo deriving (Show)++-- standalone deriving method not in the same position+-- deriving instance Eq Foo++-- a :: Foo -> Foo -> Bool+-- a = (==)
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected view
@@ -0,0 +1,12 @@+5:13-18 TTypeFamily "XList"+5:19-20 TTypeVariable "a"+8:15-20 TTypeFamily "XList"+8:21-25 TTypeConstructor "Char"+8:28-33 TDataConstructor "XCons"+8:35-39 TTypeConstructor "Char"+8:42-47 TTypeFamily "XList"+8:48-52 TTypeConstructor "Char"+8:56-60 TDataConstructor "XNil"+11:15-20 TTypeFamily "XList"+11:26-35 TDataConstructor "XListUnit"+11:37-40 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+module TDatafamily where++-- Declare a list-like data family+data family XList a++-- Declare a list-like instance for Char+data instance XList Char = XCons !Char !(XList Char) | XNil++-- Declare a number-like instance for ()+data instance XList () = XListUnit !Int
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected view
@@ -0,0 +1,4 @@+3:6-9 TTypeConstructor "Foo"+3:12-15 TDataConstructor "Foo"+3:16-19 TTypeConstructor "Int"+3:30-32 TClass "Eq"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs view
@@ -0,0 +1,3 @@+module TDataType where++data Foo = Foo Int deriving (Eq)
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected view
@@ -0,0 +1,5 @@+3:8-17 TModule "System.IO"+5:1-3 TVariable "go"+5:7-9 TTypeConstructor "IO"+6:1-3 TVariable "go"+6:6-11 TFunction "print"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs view
@@ -0,0 +1,6 @@+module TDatatypeImported where++import System.IO++go :: IO ()+go = print 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected view
@@ -0,0 +1,5 @@+4:5-10 TVariable "hello"+5:1-6 TVariable "hello"+5:10-13 TTypeConstructor "Int"+6:1-6 TVariable "hello"+6:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs view
@@ -0,0 +1,9 @@+module TDoc where++-- |+-- `hello`+hello :: Int+hello = length "Hello, Haskell!"+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected view
@@ -0,0 +1,11 @@+3:1-2 TFunction "f"+3:13-14 TTypeVariable "a"+3:16-17 TTypeVariable "a"+3:21-22 TTypeVariable "a"+4:1-2 TFunction "f"+4:3-4 TVariable "x"+4:7-8 TVariable "x"+6:1-2 TVariable "x"+6:6-7 TTypeVariable "a"+7:1-2 TVariable "x"+7:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs view
@@ -0,0 +1,7 @@+module TFunction where++f :: forall a. a -> a+f x = x++x :: a+x = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected view
@@ -0,0 +1,5 @@+3:1-2 TVariable "y"+3:6-9 TTypeConstructor "Int"+4:1-2 TVariable "y"+4:9-10 TFunction "f"+4:11-12 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs view
@@ -0,0 +1,4 @@+module TFunctionLet where++y :: Int+y = let f x = 1 in 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected view
@@ -0,0 +1,7 @@+3:1-2 TFunction "f"+3:6-9 TTypeConstructor "Int"+3:13-16 TTypeConstructor "Int"+4:1-2 TFunction "f"+4:7-8 TFunction "g"+6:5-6 TFunction "g"+6:7-8 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs view
@@ -0,0 +1,8 @@+module TFunctionLocal where++f :: Int -> Int+f 1 = g 1+  where+    g x = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected view
@@ -0,0 +1,17 @@+3:6-8 TTypeSynonym "T1"+3:11-14 TTypeConstructor "Int"+3:18-21 TTypeConstructor "Int"+4:6-8 TTypeSynonym "T2"+4:18-19 TTypeVariable "a"+4:21-22 TTypeVariable "a"+4:26-27 TTypeVariable "a"+5:1-3 TFunction "f1"+5:7-9 TTypeSynonym "T1"+6:1-3 TFunction "f1"+6:4-5 TVariable "x"+6:8-9 TVariable "x"+7:1-3 TFunction "f2"+7:7-9 TTypeSynonym "T2"+8:1-3 TFunction "f2"+8:4-5 TVariable "x"+8:8-9 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs view
@@ -0,0 +1,9 @@+module TFunctionUnderTypeSynonym where++type T1 = Int -> Int+type T2 = forall a. a -> a+f1 :: T1+f1 x = x+f2 :: T2+f2 x = x+
+ plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected view
@@ -0,0 +1,13 @@+5:6-9 TTypeConstructor "Lam"+6:3-7 TDataConstructor "Lift"+6:11-12 TTypeVariable "a"+6:36-39 TTypeConstructor "Lam"+6:40-41 TTypeVariable "a"+7:3-6 TDataConstructor "Lam"+7:12-15 TTypeConstructor "Lam"+7:16-17 TTypeVariable "a"+7:21-24 TTypeConstructor "Lam"+7:25-26 TTypeVariable "b"+7:36-39 TTypeConstructor "Lam"+7:41-42 TTypeVariable "a"+7:46-47 TTypeVariable "b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+module TGADT where++data Lam :: * -> * where+  Lift :: a                     -> Lam a        -- ^ lifted value+  Lam  :: (Lam a -> Lam b)      -> Lam (a -> b) -- ^ lambda abstraction
+ plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected view
@@ -0,0 +1,7 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:16-19 TTypeConstructor "Int"+5:10-14 TClass "Show"+5:15-18 TTypeConstructor "Foo"+6:5-9 TClassMethod "show"+6:12-21 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs view
@@ -0,0 +1,6 @@+module TInstanceClassMethodBind where+++data Foo = Foo Int+instance Show Foo where+    show = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected view
@@ -0,0 +1,2 @@+4:1-3 TFunction "go"+4:8-12 TClassMethod "show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs view
@@ -0,0 +1,5 @@+module TInstanceClassMethodUse where+++go  =  show+
+ plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs view
@@ -0,0 +1,5 @@+module TModuleA where++data Game = Game {a𐐀b :: Int}++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs view
@@ -0,0 +1,8 @@+module TModuleB where++import TModuleA+import qualified TModuleA++go = Game 1++a𐐀bb = TModuleA.a𐐀b go
+ plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected view
@@ -0,0 +1,6 @@+3:1-2 TVariable "x"+3:7-9 TClass "Eq"+3:10-11 TTypeVariable "a"+3:16-17 TTypeVariable "a"+4:1-2 TVariable "x"+4:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs view
@@ -0,0 +1,5 @@+module TNoneFunctionWithConstraint where++x :: (Eq a) => a+x = undefined+
+ plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected view
@@ -0,0 +1,33 @@+4:1-3 TFunction "go"+4:4-5 TFunction "f"+4:6-7 TVariable "x"+4:10-11 TFunction "f"+4:11-12 TOperator "$"+4:12-13 TVariable "x"+6:2-6 TOperator "$$$$"+7:1-2 TVariable "x"+7:7-11 TOperator "$$$$"+8:6-7 TTypeVariable "a"+8:8-11 TOperator ":+:"+8:12-13 TTypeVariable "b"+8:16-19 TDataConstructor "Add"+8:20-21 TTypeVariable "a"+8:22-23 TTypeVariable "b"+9:7-10 TOperator ":-:"+9:12-13 TTypeVariable "a"+9:14-15 TTypeVariable "b"+9:19-20 TTypeVariable "a"+9:22-23 TTypeVariable "b"+11:1-4 TFunction "add"+11:8-11 TTypeConstructor "Int"+11:12-15 TOperator ":+:"+11:16-19 TTypeConstructor "Int"+11:23-26 TTypeConstructor "Int"+11:27-30 TOperator ":-:"+11:31-34 TTypeConstructor "Int"+13:1-4 TFunction "add"+13:6-9 TDataConstructor "Add"+13:10-11 TVariable "x"+13:12-13 TVariable "y"+13:18-19 TVariable "x"+13:21-22 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs view
@@ -0,0 +1,13 @@+module TOperator where++-- imported operator+go f x = f$x+-- operator defined in local module+($$$$) = b+x = 1 $$$$ 2+data a :+: b = Add a b+type (:-:) a b = (a, b)+-- type take precedence over operator+add :: Int :+: Int -> Int :-: Int+-- class method take precedence over operator+add (Add x y) = (x, y)
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected view
@@ -0,0 +1,2 @@+4:1-2 TFunction "g"+4:4-11 TDataConstructor "Nothing"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs view
@@ -0,0 +1,6 @@+module TPatternMatch where+++g (Nothing, _) = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected view
@@ -0,0 +1,1 @@+5:9-12 TPatternSynonym "Foo"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+module TPatternSynonym where+++pattern Foo = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected view
@@ -0,0 +1,7 @@+3:2-3 TVariable "a"+3:5-6 TVariable "b"+5:1-2 TFunction "f"+5:3-4 TFunction "g"+5:5-6 TVariable "y"+5:9-10 TFunction "g"+5:11-12 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs view
@@ -0,0 +1,9 @@+module TVariable where++(a, b) = (1, 2)++f g y = g y++++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected view
@@ -0,0 +1,12 @@+3:18-27 TModule "Data.List"+6:1-2 TVariable "a"+6:5-13 TModule "Prelude."+6:13-22 TVariable "undefined"+7:1-2 TVariable "b"+7:8-18 TModule "Data.List."+7:18-22 TClassMethod "elem"+8:1-2 TVariable "c"+8:6-14 TModule "Prelude."+8:14-15 TOperator "+"+9:1-2 TVariable "d"+9:6-7 TOperator "+"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs view
@@ -0,0 +1,9 @@+module TQualifiedName where++import qualified Data.List+++a = Prelude.undefined+b = 1 `Data.List.elem` [1, 2]+c = (Prelude.+) 1 1+d = (+) 1 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected view
@@ -0,0 +1,4 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:18-21 TRecordField "foo"+4:25-28 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs view
@@ -0,0 +1,7 @@+module TRecord where+++data Foo = Foo { foo :: Int }+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected view
@@ -0,0 +1,4 @@+5:6-9 TTypeConstructor "Foo"+5:12-15 TDataConstructor "Foo"+5:18-21 TRecordField "boo"+5:26-32 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE DuplicateRecordFields      #-}++module TRecordDuplicateRecordFields where++data Foo = Foo { boo :: !String }
+ plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected view
@@ -0,0 +1,8 @@+4:13-16 TTypeFamily "Foo"+4:17-18 TTypeVariable "a"+5:3-6 TTypeFamily "Foo"+5:7-10 TTypeConstructor "Int"+5:13-16 TTypeConstructor "Int"+6:3-6 TTypeFamily "Foo"+6:7-8 TTypeVariable "a"+6:11-17 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module TTypefamily where++type family Foo a where+  Foo Int = Int+  Foo a = String
+ plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected view
@@ -0,0 +1,1 @@+3:1-4 TVariable "a\66560b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs view
@@ -0,0 +1,5 @@+module TUnicodeSyntax where++a𐐀b = "a𐐀b"++
+ plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected view
@@ -0,0 +1,4 @@+4:1-6 TVariable "hello"+4:10-13 TTypeConstructor "Int"+5:1-6 TVariable "hello"+5:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs view
@@ -0,0 +1,8 @@+module TValBind where+++hello :: Int+hello = length "Hello, Haskell!"+++
+ plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE PatternSynonyms       #-}++module Ide.Plugin.Splice+    ( descriptor,+    )+where++import           Control.Applicative             (Alternative ((<|>)))+import           Control.Arrow                   ( Arrow(first) )+import           Control.Exception              ( SomeException )+import qualified Control.Foldl                   as L+import           Control.Lens                    (Identity (..), ix, view, (%~),+                                                  (<&>), (^.))+import           Control.Monad                   ( guard, unless, forM )+import           Control.Monad.Error.Class       ( MonadError(throwError) )+import           Control.Monad.Extra             (eitherM)+import qualified Control.Monad.Fail              as Fail+import           Control.Monad.IO.Unlift         ( MonadIO(..), askRunInIO )+import           Control.Monad.Trans.Class       ( MonadTrans(lift) )+import           Control.Monad.Trans.Except      ( ExceptT(..), runExceptT )+import           Control.Monad.Trans.Maybe+import           Data.Aeson                      hiding (Null)+import qualified Data.Bifunctor                  as B (first)+import           Data.Foldable                   (Foldable (foldl'))+import           Data.Function+import           Data.Generics+import qualified Data.Kind                       as Kinds+import           Data.List                       (sortOn)+import           Data.Maybe                      (fromMaybe, listToMaybe,+                                                  mapMaybe)+import qualified Data.Text                       as T+import           Development.IDE+import           Development.IDE.Core.PluginUtils+import           Development.IDE.GHC.Compat      as Compat hiding (getLoc)+import           Development.IDE.GHC.Compat.ExactPrint+import qualified Development.IDE.GHC.Compat.Util as Util+import           Development.IDE.GHC.ExactPrint+import           Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT))++#if MIN_VERSION_ghc(9,4,1)++import           GHC.Data.Bag (Bag)++#endif++import           GHC.Exts+++import           GHC.Parser.Annotation (SrcSpanAnn'(..))+import qualified GHC.Types.Error as Error+++import           Ide.Plugin.Splice.Types+import           Ide.Types+import           Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT)+import           Language.LSP.Server+import           Language.LSP.Protocol.Types+import           Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Lens         as J+import Ide.Plugin.Error (PluginError(PluginInternalError))++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId =+    (defaultPluginDescriptor plId "Provides a code action to evaluate a TemplateHaskell splice")+        { pluginCommands = commands+        , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeAction+        }++commands :: [PluginCommand IdeState]+commands =+    [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace+    -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented+    ]++newtype SubSpan = SubSpan {runSubSpan :: SrcSpan}++instance Eq SubSpan where+    (==) = (==) `on` runSubSpan++instance Ord SubSpan where+    (<=) = coerce isSubspanOf++expandTHSplice ::+    -- | Inplace?+    ExpandStyle ->+    CommandFunction IdeState ExpandSpliceParams+expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do+    clientCapabilities <- getClientCapabilities+    rio <- askRunInIO+    let reportEditor :: ReportEditor+        reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs))+        expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit+        expandManually fp = do+            mresl <-+                liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp+            (TcModuleResult {..}, _) <-+                maybe+                (throwError $ PluginInternalError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again."+                )+                pure mresl+            reportEditor+                MessageType_Warning+                [ "Expansion in type-checking phase failed;"+                , "trying to expand manually, but note that it is less rigorous."+                ]+            pm <- runActionE "expandTHSplice.fallback.GetParsedModule" ideState $+                        useE GetParsedModule fp+            (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm++            manualCalcEdit+                clientCapabilities+                reportEditor+                range+                ps+                hscEnv+                tmrTypechecked+                spliceSpan+                _eStyle+                params++        withTypeChecked fp TcModuleResult {..} = do+            (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed+            let Splices {..} = tmrTopLevelSplices+            let exprSuperSpans =+                    listToMaybe $ findSubSpansDesc srcSpan exprSplices+                _patSuperSpans =+                    listToMaybe $ findSubSpansDesc srcSpan patSplices+                typeSuperSpans =+                    listToMaybe $ findSubSpansDesc srcSpan typeSplices+                declSuperSpans =+                    listToMaybe $ findSubSpansDesc srcSpan declSplices++                graftSpliceWith ::+                    forall ast.+                    HasSplice AnnListItem ast =>+                    Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs)) ->+                    Maybe (Either String WorkspaceEdit)+                graftSpliceWith expandeds =+                    expandeds <&> \(_, expanded) ->+                        transform+                            dflags+                            clientCapabilities+                            verTxtDocId+                            (graft (RealSrcSpan spliceSpan Nothing) expanded)+                            ps+            maybe (throwError $ PluginInternalError "No splice information found") (either (throwError . PluginInternalError . T.pack) pure) $+                case spliceContext of+                    Expr -> graftSpliceWith exprSuperSpans+                    Pat ->++                        graftSpliceWith _patSuperSpans++                    HsType -> graftSpliceWith typeSuperSpans+                    HsDecl ->+                        declSuperSpans <&> \(_, expanded) ->+                            transform+                                dflags+                                clientCapabilities+                                verTxtDocId+                                (graftDecls (RealSrcSpan spliceSpan Nothing) expanded)+                                ps+                                <&>+                                -- FIXME: Why ghc-exactprint sweeps preceding comments?+                                adjustToRange (verTxtDocId ^. J.uri) range++    res <- liftIO $ runMaybeT $ do++            fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri (verTxtDocId ^. J.uri)+            eedits <-+                ( lift . runExceptT . withTypeChecked fp+                        =<< MaybeT+                            (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp)+                    )+                    <|> lift (runExceptT $ expandManually fp)++            case eedits of+                Left err -> do+                    reportEditor+                        MessageType_Error+                        [T.pack $ "Error during expanding splice: " <> show (pretty err)]+                    pure (Left err)+                Right edits ->+                    pure (Right edits)+    case res of+      Nothing -> pure $ Right $ InR Null+      Just (Left err) -> pure $ Left $ err+      Just (Right edit) -> do+        _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+        pure $ Right $ InR Null++    where+        range = realSrcSpanToRange spliceSpan+        srcSpan = RealSrcSpan spliceSpan Nothing+++setupHscEnv+    :: IdeState+    -> NormalizedFilePath+    -> ParsedModule+    -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)+setupHscEnv ideState fp pm = do+    hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $+                    useE GhcSessionDeps fp+    let ps = annotateParsedSource pm+        hscEnv0 = hscEnvWithImportPaths hscEnvEq+        modSum = pm_mod_summary pm+    hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum+    pure (ps, hscEnv, hsc_dflags hscEnv)++setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv+setupDynFlagsForGHCiLike env dflags = do+    let dflags3 = setInterpreterLinkerOptions dflags+        platform = targetPlatform dflags3+        dflags3a = setWays hostFullWays dflags3+        dflags3b =+            foldl gopt_set dflags3a $+                concatMap (wayGeneralFlags platform) hostFullWays+        dflags3c =+            foldl gopt_unset dflags3b $+                concatMap (wayUnsetGeneralFlags platform) hostFullWays+        dflags4 =+            dflags3c+                `gopt_set` Opt_ImplicitImportQualified+                `gopt_set` Opt_IgnoreOptimChanges+                `gopt_set` Opt_IgnoreHpcChanges+                `gopt_unset` Opt_DiagnosticsShowCaret+    initializePlugins (hscSetFlags dflags4 env)++adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit+adjustToRange uri ran (WorkspaceEdit mhult mlt x) =+    WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) x+    where+        adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit+        adjustTextEdits eds =+            let minStart =+                    case L.fold (L.premap (view J.range) L.minimum) eds of+                        Nothing -> error "impossible"+                        Just v -> v+            in adjustLine minStart <$> eds++        adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit)+        adjustATextEdits = fmap $ \case+          InL t -> InL $ runIdentity $ adjustTextEdits (Identity t)+          InR AnnotatedTextEdit{_range, _newText, _annotationId} ->+            let oldTE = TextEdit{_range,_newText}+              in let TextEdit{_range,_newText} = runIdentity $ adjustTextEdits (Identity oldTE)+                in InR $ AnnotatedTextEdit{_range,_newText,_annotationId}++        adjustWS = ix uri %~ adjustTextEdits+        adjustDoc :: DocumentChange -> DocumentChange+        adjustDoc (InR es) = InR es+        adjustDoc (InL es)+            | es ^. J.textDocument . J.uri == uri =+                InL $ es & J.edits %~ adjustATextEdits+            | otherwise = InL es++        adjustLine :: Range -> TextEdit -> TextEdit+        adjustLine bad =+            J.range %~ \r ->+                if r == bad then ran else bad++-- Define a pattern to get hold of a `SrcSpan` from the location part of a+-- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations;+-- earlier it will just be a plain `SrcSpan`.+{-# COMPLETE AsSrcSpan #-}+pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a+pattern AsSrcSpan locA <- SrcSpanAnn {locA}++findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]+findSubSpansDesc srcSpan =+    sortOn (Down . SubSpan . fst)+        . mapMaybe+            ( \(L (AsSrcSpan spn) _, e) -> do+                guard (spn `isSubspanOf` srcSpan)+                pure (spn, e)+            )++data SpliceClass where+    OneToOneAST :: HasSplice AnnListItem ast => Proxy# ast -> SpliceClass+    IsHsDecl :: SpliceClass++#if MIN_VERSION_ghc(9,5,0)+data HsSpliceCompat pass+  = UntypedSplice (HsUntypedSplice pass)+  | TypedSplice (LHsExpr pass)+#endif+++class (Outputable (ast GhcRn), ASTElement l (ast GhcPs)) => HasSplice l ast where+    type SpliceOf ast :: Kinds.Type -> Kinds.Type+    matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)+    expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars)++instance HasSplice AnnListItem HsExpr where+#if MIN_VERSION_ghc(9,5,0)+    type SpliceOf HsExpr = HsSpliceCompat+    matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl)+    matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl)+#else+    type SpliceOf HsExpr = HsSplice+    matchSplice _ (HsSpliceE _ spl) = Just spl+#endif+    matchSplice _ _                 = Nothing+#if MIN_VERSION_ghc(9,5,0)+    expandSplice _ (UntypedSplice e) = fmap (first Right) $ rnUntypedSpliceExpr e+    expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice e+#else+    expandSplice _ = fmap (first Right) . rnSpliceExpr+#endif++instance HasSplice AnnListItem Pat where+#if MIN_VERSION_ghc(9,5,0)+    type SpliceOf Pat = HsUntypedSplice+#else+    type SpliceOf Pat = HsSplice+#endif+    matchSplice _ (SplicePat _ spl) = Just spl+    matchSplice _ _                 = Nothing+    expandSplice _ =+#if MIN_VERSION_ghc(9,5,0)+      fmap (first (Left . unLoc . utsplice_result . snd )) .+#endif+      rnSplicePat+++instance HasSplice AnnListItem HsType where+#if MIN_VERSION_ghc(9,5,0)+    type SpliceOf HsType = HsUntypedSplice+#else+    type SpliceOf HsType = HsSplice+#endif+    matchSplice _ (HsSpliceTy _ spl) = Just spl+    matchSplice _ _                  = Nothing+    expandSplice _ = fmap (first Right) . rnSpliceType++classifyAST :: SpliceContext -> SpliceClass+classifyAST = \case+    Expr   -> OneToOneAST @HsExpr proxy#+    HsDecl -> IsHsDecl+    Pat    -> OneToOneAST @Pat proxy#+    HsType -> OneToOneAST @HsType proxy#++type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m ()++manualCalcEdit ::+    ClientCapabilities ->+    ReportEditor ->+    Range ->+    Annotated ParsedSource ->+    HscEnv ->+    TcGblEnv ->+    RealSrcSpan ->+    ExpandStyle ->+    ExpandSpliceParams ->+    ExceptT PluginError IO WorkspaceEdit+manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do+    (warns, resl) <-+        ExceptT $ do+            (msgs, eresl) <-+                initTcWithGbl hscEnv typechkd srcSpan $+                    case classifyAST spliceContext of+                        IsHsDecl -> fmap (fmap $ adjustToRange (verTxtDocId ^. J.uri) ran) $+                            flip (transformM dflags clientCapabilities verTxtDocId) ps $+                                graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case+                                    (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do+                                        eExpr <-+                                            eitherM (fail . show) pure+                                                $ TransformT $ lift+                                                    ( lift $+                                                        Util.try @_ @SomeException $+                                                            (fst <$> rnTopSpliceDecls spl)+                                                    )+                                        pure $ Just eExpr+                                    _ -> pure Nothing+                        OneToOneAST astP ->+                            flip (transformM dflags clientCapabilities verTxtDocId) ps $+                                graftWithM (RealSrcSpan srcSpan Nothing) $ \case+                                    (L _spn (matchSplice astP -> Just spl)) -> do+                                        eExpr <-+                                            eitherM (fail . show) pure+                                                $ TransformT $ lift+                                                    ( lift $+                                                        Util.try @_ @SomeException $+                                                            (fst <$> expandSplice astP spl)+                                                    )+                                        Just <$> case eExpr of+                                            Left x -> pure $ L _spn x+                                            Right y -> unRenamedE dflags y+                                    _ -> pure Nothing+            let (warns, errs) =+                                (Error.getWarningMessages msgs, Error.getErrorMessages msgs)+            pure $ (warns,) <$> maybe (throwError $ PluginInternalError $ T.pack $ showErrors errs)+                                    (B.first (PluginInternalError . T.pack)) eresl++    unless+        (null warns)+        $ reportEditor+            MessageType_Warning+            [ "Warning during expanding: "+            , ""+            , T.pack (showErrors warns)+            ]+    pure resl+    where+        dflags = hsc_dflags hscEnv++#if MIN_VERSION_ghc(9,4,1)+        showErrors = showBag+#else+        showErrors = show+#endif++#if MIN_VERSION_ghc(9,4,1)+showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String+showBag = show . fmap (fmap toDiagnosticMessage)++toDiagnosticMessage :: forall a. Error.Diagnostic a => a -> Error.DiagnosticMessage+toDiagnosticMessage message =+    Error.DiagnosticMessage+        { diagMessage = Error.diagnosticMessage+#if MIN_VERSION_ghc(9,5,0)+                          (Error.defaultDiagnosticOpts @a)+#endif+                          message++        , diagReason  = Error.diagnosticReason  message+        , diagHints   = Error.diagnosticHints   message+        }+#endif++-- | FIXME:  Is thereAny "clever" way to do this exploiting TTG?+unRenamedE ::+    forall ast m l.+    (Fail.MonadFail m, HasSplice l ast) =>+    DynFlags ->+    ast GhcRn ->+    TransformT m (LocatedAn l (ast GhcPs))+unRenamedE dflags expr = do+    uniq <- show <$> uniqueSrcSpanT+    expr' <-+        either (fail . showErrors) pure $+        parseAST @_ @(ast GhcPs) dflags uniq $+            showSDoc dflags $ ppr expr+    pure expr'+  where+#if MIN_VERSION_ghc(9,4,1)+    showErrors = showBag . Error.getMessages+#else+    showErrors = show+#endif++data SearchResult r =+    Continue | Stop | Here r+    deriving (Read, Show, Eq, Ord, Data, Typeable)++fromSearchResult :: SearchResult a -> Maybe a+fromSearchResult (Here r) = Just r+fromSearchResult _        = Nothing++-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)+-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs?+codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+codeAction state plId (CodeActionParams _ _ docId ran _) = do+    verTxtDocId <- lift $ getVersionedTextDoc docId+    liftIO $ fmap (fromMaybe ( InL [])) $+        runMaybeT $ do+            fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri+            ParsedModule {..} <-+                MaybeT . runAction "splice.codeAction.GitHieAst" state $+                    use GetParsedModule fp+            let spn = rangeToRealSrcSpan fp ran+                mouterSplice = something' (detectSplice spn) pm_parsed_source+            mcmds <- forM mouterSplice $+                \(spliceSpan, spliceContext) ->+                    forM expandStyles $ \(_, (title, cmdId)) -> do+                        let params = ExpandSpliceParams {verTxtDocId, ..}+                            act = mkLspCommand plId cmdId title (Just [toJSON params])+                        pure $+                            InR $+                                CodeAction title (Just CodeActionKind_RefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing++            pure $ InL $ fromMaybe mempty mcmds+    where+        theUri = docId ^. J.uri+        detectSplice ::+            RealSrcSpan ->+            GenericQ (SearchResult (RealSrcSpan, SpliceContext))+        detectSplice spn =+          let+            spanIsRelevant x = RealSrcSpan spn Nothing `isSubspanOf` x+          in+            mkQ+                Continue+                ( \case+                    (L (AsSrcSpan l@(RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs)+                        | spanIsRelevant l ->+                            case expr of+#if MIN_VERSION_ghc(9,5,0)+                                HsTypedSplice{} -> Here (spLoc, Expr)+                                HsUntypedSplice{} -> Here (spLoc, Expr)+#else+                                HsSpliceE {} -> Here (spLoc, Expr)+#endif+                                _            -> Continue+                    _ -> Stop+                )+                `extQ` \case+                    (L (AsSrcSpan l@(RealSrcSpan spLoc _)) pat :: LPat GhcPs)+                        | spanIsRelevant l ->+                            case pat of+                                SplicePat{} -> Here (spLoc, Pat)+                                _           -> Continue+                    _ -> Stop+                `extQ` \case+                    (L (AsSrcSpan l@(RealSrcSpan spLoc _)) ty :: LHsType GhcPs)+                        | spanIsRelevant l ->+                            case ty of+                                HsSpliceTy {} -> Here (spLoc, HsType)+                                _             -> Continue+                    _ -> Stop+                `extQ` \case+                    (L (AsSrcSpan l@(RealSrcSpan spLoc _)) decl :: LHsDecl GhcPs)+                        | spanIsRelevant l ->+                            case decl of+                                SpliceD {} -> Here (spLoc, HsDecl)+                                _          -> Continue+                    _ -> Stop++-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received,+--   and picks innermost result.+something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a)+something' f =  go+    where+        go :: GenericQ (Maybe a)+        go x =+            case f x of+              Stop -> Nothing+              resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x)
+ plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings  #-}++module Ide.Plugin.Splice.Types where++import           Data.Aeson                  (FromJSON, ToJSON)+import qualified Data.Text                   as T+ -- This import is needed for the ToJSON/FromJSON instances of RealSrcSpan+import           Development.IDE             ()+import           Development.IDE.GHC.Compat  (RealSrcSpan)+import           GHC.Generics                (Generic)+import           Ide.Types                   (CommandId)+import           Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier)++-- | Parameter for the addMethods PluginCommand.+data ExpandSpliceParams = ExpandSpliceParams+    { verTxtDocId   :: VersionedTextDocumentIdentifier+    , spliceSpan    :: RealSrcSpan+    , spliceContext :: SpliceContext+    }+    deriving (Show, Eq, Generic)+    deriving anyclass (ToJSON, FromJSON)++-- FIXME: HsDecl needs different treatment of splicing.+data SpliceContext = Expr | HsDecl | Pat | HsType+    deriving (Read, Show, Eq, Ord, Generic)+    deriving anyclass (ToJSON, FromJSON)++data ExpandStyle = Inplace | Commented+    deriving (Read, Show, Eq, Ord, Generic)++expandStyles :: [(ExpandStyle, (T.Text, CommandId))]+expandStyles =+    [ (Inplace, (inplaceCmdName, expandInplaceId))+    -- , (Commented, commentedCmdName, expandCommentedId)+    ]++toExpandCmdTitle :: ExpandStyle -> T.Text+toExpandCmdTitle Inplace   = inplaceCmdName+toExpandCmdTitle Commented = commentedCmdName++toCommandId :: ExpandStyle -> CommandId+toCommandId Inplace   = expandInplaceId+toCommandId Commented = expandCommentedId++expandInplaceId, expandCommentedId :: CommandId+expandInplaceId = "expandTHSpliceInplace"+expandCommentedId = "expandTHSpliceCommented"++inplaceCmdName :: T.Text+inplaceCmdName = "expand TemplateHaskell Splice (in-place)"++commentedCmdName :: T.Text+commentedCmdName = "expand TemplateHaskell Splice (commented-out)"
+ plugins/hls-splice-plugin/test/Main.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ViewPatterns          #-}+module Main+  ( main+  ) where++import           Control.Monad           (void)+import           Data.List               (find)+import           Data.Row+import           Data.Text               (Text)+import qualified Data.Text               as T+import qualified Data.Text.IO            as T+import qualified Ide.Plugin.Splice       as Splice+import           Ide.Plugin.Splice.Types+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++splicePlugin :: PluginTestDescriptor ()+splicePlugin = mkPluginTestDescriptor' Splice.descriptor "splice"++tests :: TestTree+tests = testGroup "splice"+  [ goldenTest "TSimpleExp" Inplace 6 15+  , goldenTest "TSimpleExp" Inplace 6 24+  , goldenTest "TTypeAppExp" Inplace 7 5+  , goldenTest "TErrorExp" Inplace 6 15+  , goldenTest "TErrorExp" Inplace 6 51+  , goldenTest "TQQExp" Inplace 6 17+  , goldenTest "TQQExp" Inplace 6 25+  , goldenTest "TQQExpError" Inplace 6 13+  , goldenTest "TQQExpError" Inplace 6 22+  , testGroup "Pattern Splices"+      [ goldenTest "TSimplePat" Inplace 6 3+      , goldenTest "TSimplePat" Inplace 6 22+      , goldenTest "TSimplePat" Inplace 6 3+      , goldenTest "TSimplePat" Inplace 6 22+      , goldenTest "TErrorPat" Inplace 6 3+      , goldenTest "TErrorPat" Inplace 6 18+      , goldenTest "TQQPat" Inplace 6 3+      , goldenTest "TQQPat" Inplace 6 11+      , goldenTest "TQQPatError" Inplace 6 3+      , goldenTest "TQQPatError" Inplace 6 11+      ]+  , goldenTest "TSimpleType" Inplace 5 12+  , goldenTest "TSimpleType" Inplace 5 22+  , goldenTest "TTypeTypeError" Inplace 7 12+  , goldenTest "TTypeTypeError" Inplace 7 52+  , goldenTest "TQQType" Inplace 8 19+  , goldenTest "TQQType" Inplace 8 28+  , goldenTest "TQQTypeTypeError" Inplace 8 19+  , goldenTest "TQQTypeTypeError" Inplace 8 28+  , goldenTest "TSimpleDecl" Inplace 8 1+  , goldenTest "TQQDecl" Inplace 5 1+  , goldenTestWithEdit "TTypeKindError" (+        if ghcVersion >= GHC96 then+          "96-expected"+        else+          "expected"+      ) Inplace 7 9+  , goldenTestWithEdit "TDeclKindError" "expected" Inplace 8 1+  ]++goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree+goldenTest fp tc line col =+  goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do+    -- wait for the entire build to finish, so that code actions that+    -- use stale data will get uptodate stuff+    void waitForBuildQueue+    actions <- getCodeActions doc $ pointRange line col+    case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of+      Just (InR CodeAction {_command = Just c}) -> do+        executeCommand c+        void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+      _ -> liftIO $ assertFailure "No CodeAction detected"++goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree+goldenTestWithEdit fp expect tc line col =+  goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp expect "hs" $ \doc -> do+     orig <- documentContents doc+     let+       lns = T.lines orig+       theRange =+         Range+         { _start = Position 0 0+         , _end = Position (fromIntegral $ length lns + 1) 1+         }+     waitForAllProgressDone -- cradle+     waitForAllProgressDone+     alt <- liftIO $ T.readFile (fp <.> "error.hs")+     void $ applyEdit doc $ TextEdit theRange alt+     changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange+                                                        .+ #rangeLength .== Nothing+                                                        .+ #text .== alt]+     void waitForDiagnostics+     -- wait for the entire build to finish+     void waitForBuildQueue+     actions <- getCodeActions doc $ pointRange line col+     case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of+       Just (InR CodeAction {_command = Just c}) -> do+         executeCommand c+         void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+       _ -> liftIO $ assertFailure "No CodeAction detected"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-splice-plugin" </> "test" </> "testdata"++pointRange :: Int -> Int -> Range+pointRange (subtract 1 -> fromIntegral -> line) (subtract 1 -> fromIntegral -> col) =+  Range (Position line col) (Position line $ col + 1)++-- | Get the title of a code action.+codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle InL {}                    = Nothing+codeActionTitle (InR CodeAction {_title}) = Just _title
+ plugins/hls-splice-plugin/test/testdata/QQ.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}+module QQ (str) where++import Language.Haskell.TH+    ( mkName,+      stringL,+      litP,+      clause,+      litE,+      normalB,+      funD,+      sigD,+      litT,+      strTyLit )+import Language.Haskell.TH.Quote (QuasiQuoter (..))++str :: QuasiQuoter+str =+    QuasiQuoter+        { quoteExp = litE . stringL+        , quotePat = litP . stringL+        , quoteType = litT . strTyLit+        , quoteDec = \name ->+            sequence+                [ sigD (mkName name) [t|String|]+                , funD (mkName name) [clause [] (normalB $ litE $ stringL name) []]+                ]+        }
+ plugins/hls-splice-plugin/test/testdata/TDeclKindError.error.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module TSimpleDecl where+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )++-- Foo+--  Bar+$(sequence+    [sigD (mkName "foo") [t|Int|]+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]+    ,sigD (mkName "bar") [t|Int|]+    ]+    )+-- Bar+-- ee+-- dddd
+ plugins/hls-splice-plugin/test/testdata/TDeclKindError.expected.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module TSimpleDecl where+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )++-- Foo+--  Bar+foo :: Int+foo = 42+bar :: Int+-- Bar+-- ee+-- dddd
+ plugins/hls-splice-plugin/test/testdata/TDeclKindError.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module TSimpleDecl where+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )++-- Foo+--  Bar+$(sequence+    [sigD (mkName "foo") [t|Int|]+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]+    ]+    )+-- Bar+-- ee+-- dddd
+ plugins/hls-splice-plugin/test/testdata/TErrorExp.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TErrorExp where+import Language.Haskell.TH ( tupE, litE, integerL )++main :: IO ()+main = return (42, ())
+ plugins/hls-splice-plugin/test/testdata/TErrorExp.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TErrorExp where+import Language.Haskell.TH ( tupE, litE, integerL )++main :: IO ()+main = return $(tupE [litE $ integerL 42, tupE []])
+ plugins/hls-splice-plugin/test/testdata/TErrorPat.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TErrorPat where+import Language.Haskell.TH ( conP )++f :: () -> ()+f True = x
+ plugins/hls-splice-plugin/test/testdata/TErrorPat.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TErrorPat where+import Language.Haskell.TH ( conP )++f :: () -> ()+f $(conP 'True []) = x
+ plugins/hls-splice-plugin/test/testdata/TQQDecl.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQDecl where+import QQ (str)++foo :: String+foo = "foo"
+ plugins/hls-splice-plugin/test/testdata/TQQDecl.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQDecl where+import QQ (str)++[str|foo|]
+ plugins/hls-splice-plugin/test/testdata/TQQExp.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQExp where+import QQ++main :: IO ()+main = putStrLn "str"
+ plugins/hls-splice-plugin/test/testdata/TQQExp.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQExp where+import QQ++main :: IO ()+main = putStrLn [str|str|]
+ plugins/hls-splice-plugin/test/testdata/TQQExpError.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQExpError where+import QQ++main :: IO ()+main = pure "str"
+ plugins/hls-splice-plugin/test/testdata/TQQExpError.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQExpError where+import QQ++main :: IO ()+main = pure [str|str|]
+ plugins/hls-splice-plugin/test/testdata/TQQPat.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQPat where+import QQ++f :: String -> IO ()+f "str" = putStrLn "is str"+f _ = putStrLn " not str"
+ plugins/hls-splice-plugin/test/testdata/TQQPat.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQPat where+import QQ++f :: String -> IO ()+f [str|str|] = putStrLn "is str"+f _ = putStrLn " not str"
+ plugins/hls-splice-plugin/test/testdata/TQQPatError.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQPatError where+import QQ++f :: () -> IO ()+f "str" = putStrLn "is str"+f _ = putStrLn " not str"
+ plugins/hls-splice-plugin/test/testdata/TQQPatError.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}+module TQQPatError where+import QQ++f :: () -> IO ()+f [str|str|] = putStrLn "is str"+f _ = putStrLn " not str"
+ plugins/hls-splice-plugin/test/testdata/TQQType.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module TQQType where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy(..) )+import QQ++main :: IO (Proxy "str")+main = return Proxy
+ plugins/hls-splice-plugin/test/testdata/TQQType.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module TQQType where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy(..) )+import QQ++main :: IO (Proxy [str|str|])+main = return Proxy
+ plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module TQQTypeTypeError where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy(..) )+import QQ++main :: IO (Proxy "str")+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module TQQTypeTypeError where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy(..) )+import QQ++main :: IO (Proxy [str|str|])+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TSimpleDecl.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module TSimpleDecl where+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )++-- Foo+--  Bar+foo :: Int+foo = 42+-- Bar+-- ee+-- dddd
+ plugins/hls-splice-plugin/test/testdata/TSimpleDecl.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module TSimpleDecl where+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )++-- Foo+--  Bar+$(sequence+    [sigD (mkName "foo") [t|Int|]+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]+    ]+    )+-- Bar+-- ee+-- dddd
+ plugins/hls-splice-plugin/test/testdata/TSimpleExp.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimpleExp where+import Language.Haskell.TH ( tupE, litE, integerL )++main :: IO ()+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TSimpleExp.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimpleExp where+import Language.Haskell.TH ( tupE, litE, integerL )++main :: IO ()+main = return $(tupE [])
+ plugins/hls-splice-plugin/test/testdata/TSimplePat.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimplePat where+import Language.Haskell.TH ( varP, mkName )++f :: x -> x+f x = x
+ plugins/hls-splice-plugin/test/testdata/TSimplePat.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimplePat where+import Language.Haskell.TH ( varP, mkName )++f :: x -> x+f $(varP $ mkName "x") = x
+ plugins/hls-splice-plugin/test/testdata/TSimpleType.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimpleType where+import Language.Haskell.TH ( tupleT )++main :: IO ()+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TSimpleType.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module TSimpleType where+import Language.Haskell.TH ( tupleT )++main :: IO $(tupleT 0)+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeAppExp.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module TTypeAppExp where+import Data.Proxy++f :: Proxy Int+f = Proxy @Int
+ plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module TTypeAppExp where+import Data.Proxy++f :: Proxy Int+f = $([|Proxy @Int|])
+ plugins/hls-splice-plugin/test/testdata/TTypeKindError.96-expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeKindError where+import Language.Haskell.TH ( numTyLit, litT )+import Data.Proxy ( Proxy )++main :: 42+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeKindError.error.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeKindError where+import Language.Haskell.TH ( numTyLit, litT )+import Data.Proxy ( Proxy )++main :: $(litT (numTyLit 42))+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeKindError.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeKindError where+import Language.Haskell.TH ( numTyLit, litT )+import Data.Proxy ( Proxy )++main :: (42)+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeKindError.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeKindError where+import Language.Haskell.TH ( numTyLit, litT )+import Data.Proxy ( Proxy )++main :: IO ()+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeTypeError.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeTypeError where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy )++main :: IO (Proxy 42)+main = return ()
+ plugins/hls-splice-plugin/test/testdata/TTypeTypeError.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TTypeTypeError where+import Language.Haskell.TH ( appT, numTyLit, litT, conT )+import Data.Proxy ( Proxy )++main :: IO $(conT ''Proxy `appT` litT (numTyLit 42))+main = return ()
+ plugins/hls-splice-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,21 @@+cradle:+  direct:+    arguments:+    - QQ.hs+    - TQQExpError.hs+    - TSimpleExp.hs+    - TTypeAppExp.hs+    - TDeclKindError.hs+    - TQQPat.hs+    - TSimplePat.hs+    - TErrorExp.hs+    - TQQPatError.hs+    - TSimpleType.hs+    - TErrorPat.hs+    - TQQType.hs+    - TTypeKindError.hs+    - TQQDecl.hs+    - TQQTypeTypeError.hs+    - TTypeTypeError.hs+    - TQQExp.hs+    - TSimpleDecl.hs
+ plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE PatternSynonyms #-}+module Ide.Plugin.Stan (descriptor, Log) where++import           Compat.HieTypes             (HieFile (..))+import           Control.DeepSeq             (NFData)+import           Control.Monad               (void)+import           Control.Monad.IO.Class      (liftIO)+import           Data.Foldable               (toList)+import           Data.Hashable               (Hashable)+import qualified Data.HashMap.Strict         as HM+import           Data.Maybe                  (mapMaybe)+import qualified Data.Text                   as T+import           Development.IDE+import           Development.IDE.Core.Rules  (getHieFile)+import qualified Development.IDE.Core.Shake  as Shake+import           GHC.Generics                (Generic)+import           Ide.Plugin.Config           (PluginConfig (..))+import           Ide.Types                   (PluginDescriptor (..), PluginId,+                                              configHasDiagnostics,+                                              configInitialGenericConfig,+                                              defaultConfigDescriptor,+                                              defaultPluginDescriptor)+import qualified Language.LSP.Protocol.Types as LSP+import           Stan                        (createCabalExtensionsMap,+                                              getStanConfig)+import           Stan.Analysis               (Analysis (..), runAnalysis)+import           Stan.Category               (Category (..))+import           Stan.Cli                    (StanArgs (..))+import           Stan.Config                 (Config, ConfigP (..), applyConfig)+import           Stan.Config.Pretty          (prettyConfigCli)+import           Stan.Core.Id                (Id (..))+import           Stan.EnvVars                (EnvVars (..), envVarsToText)+import           Stan.Inspection             (Inspection (..))+import           Stan.Inspection.All         (inspectionsIds, inspectionsMap)+import           Stan.Observation            (Observation (..))+import           Stan.Report.Settings        (OutputSettings (..),+                                              ToggleSolution (..),+                                              Verbosity (..))+import           Stan.Toml                   (usedTomlFiles)+import           System.Directory            (makeRelativeToCurrentDirectory)+import           Trial                       (Fatality, Trial (..), fiasco,+                                              pattern FiascoL, pattern ResultL,+                                              prettyTrial, prettyTrialWith)++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId desc)+  { pluginRules = rules recorder plId+  , pluginConfigDescriptor = defConfigDescriptor+      { configHasDiagnostics = True+      -- We disable this plugin by default because users have been complaining about+      -- the diagnostics, see https://github.com/haskell/haskell-language-server/issues/3916+      , configInitialGenericConfig = (configInitialGenericConfig defConfigDescriptor)+        { plcGlobalOn = False+        }+      }+    }+  where+    defConfigDescriptor = defaultConfigDescriptor+    desc = "Provides stan diagnostics. Built with stan-" <> VERSION_stan++data Log = LogShake !Shake.Log+         | LogWarnConf ![(Fatality, T.Text)]+         | LogDebugStanConfigResult ![FilePath] !(Trial T.Text Config)+         | LogDebugStanEnvVars !EnvVars++-- We use this function to remove the terminal escape sequences emmited by Trial pretty printing functions.+-- See https://github.com/kowainik/trial/pull/73#issuecomment-1868233235+stripModifiers :: T.Text -> T.Text+stripModifiers = go ""+  where+    go acc txt =+      case T.findIndex (== '\x1B') txt of+        Nothing -> acc <> txt+        Just index -> let (beforeEsc, afterEsc) = T.splitAt index txt+                      in go (acc <> beforeEsc) (consumeEscapeSequence afterEsc)+    consumeEscapeSequence :: T.Text -> T.Text+    consumeEscapeSequence txt =+      case T.findIndex (== 'm') txt of+        Nothing    -> txt+        Just index -> T.drop (index + 1) txt++instance Pretty Log where+  pretty = \case+    LogShake log -> pretty log+    LogWarnConf errs -> "Fiasco encountered when trying to load stan configuration. Using default inspections:"+                        <> line <> (pretty $ show errs)+    LogDebugStanConfigResult fps t -> "Config result using: "+                                      <> pretty fps <> line <> pretty (stripModifiers $ prettyTrialWith (T.unpack . prettyConfigCli) t)+    LogDebugStanEnvVars envVars -> "EnvVars " <>+        case envVars of+            EnvVars trial@(FiascoL _) -> pretty (stripModifiers $ prettyTrial trial)++            -- if the envVars are not set, 'envVarsToText returns an empty string'+            _ -> "found: " <> (pretty $ envVarsToText envVars)++data GetStanDiagnostics = GetStanDiagnostics+  deriving (Eq, Show, Generic)++instance Hashable GetStanDiagnostics++instance NFData GetStanDiagnostics++type instance RuleResult GetStanDiagnostics = ()++rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+rules recorder plId = do+  define (cmapWithPrio LogShake recorder) $+    \GetStanDiagnostics file -> do+      config <- getPluginConfigAction plId+      if plcGlobalOn config && plcDiagnosticsOn config then do+          maybeHie <- getHieFile file+          case maybeHie of+            Nothing -> return ([], Nothing)+            Just hie -> do+              let isLoud = False -- in Stan: notJson = not isLoud+              let stanArgs =+                      StanArgs+                          { stanArgsHiedir               = "" -- :: !FilePath  -- ^ Directory with HIE files+                          , stanArgsCabalFilePath        = [] -- :: ![FilePath]  -- ^ Path to @.cabal@ files.+                          , stanArgsOutputSettings       = OutputSettings NonVerbose ShowSolution -- :: !OutputSettings  -- ^ Settings for output terminal report+                                                                                                  -- doesnt matter, because it is silenced by isLoud+                          , stanArgsReport               = Nothing -- :: !(Maybe ReportArgs)  -- ^ @HTML@ report settings+                          , stanArgsUseDefaultConfigFile = fiasco "" -- :: !(TaggedTrial Text Bool)  -- ^ Use default @.stan.toml@ file+                          , stanArgsConfigFile           = Nothing -- :: !(Maybe FilePath)  -- ^ Path to a custom configurations file.+                          , stanArgsConfig               = ConfigP+                                                            { configChecks  = fiasco "'hls-stan-plugin' doesn't receive CLI options for: checks"+                                                            , configRemoved = fiasco "'hls-stan-plugin' doesn't receive CLI options for: remove"+                                                            , configIgnored = fiasco "'hls-stan-plugin' doesn't receive CLI options for: ignore"+                                                            }+                                                            -- if they are not fiascos, .stan.toml's aren't taken into account+                          ,stanArgsJsonOut              = not isLoud -- :: !Bool  -- ^ Output the machine-readable output in JSON format instead.+                          }++              (configTrial, useDefConfig, env) <- liftIO $ getStanConfig stanArgs isLoud+              tomlsUsedByStan <- liftIO $ usedTomlFiles useDefConfig (stanArgsConfigFile stanArgs)+              logWith recorder Debug (LogDebugStanConfigResult tomlsUsedByStan configTrial)++              -- If envVar is set to 'False', stan will ignore all local and global .stan.toml files+              logWith recorder Debug (LogDebugStanEnvVars env)++              -- Note that Stan works in terms of relative paths, but the HIE come in as absolute. Without+              -- making its path relative, the file name(s) won't line up with the associated Map keys.+              relativeHsFilePath <- liftIO $ makeRelativeToCurrentDirectory $ fromNormalizedFilePath file+              let hieRelative = hie{hie_hs_file=relativeHsFilePath}++              (checksMap, ignoredObservations) <- case configTrial of+                  FiascoL es -> do+                      logWith recorder Development.IDE.Warning (LogWarnConf es)+                      -- If we can't read the config file, default to using all inspections:+                      let allInspections = HM.fromList [(relativeHsFilePath, inspectionsIds)]+                      pure (allInspections, [])+                  ResultL _warnings stanConfig -> do+                      -- HashMap of *relative* file paths to info about enabled checks for those file paths.+                      let checksMap = applyConfig [relativeHsFilePath] stanConfig+                      pure (checksMap, configIgnored stanConfig)++              -- A Map from *relative* file paths (just one, in this case) to language extension info:+              cabalExtensionsMap <- liftIO $ createCabalExtensionsMap isLoud (stanArgsCabalFilePath stanArgs) [hieRelative]+              let analysis = runAnalysis cabalExtensionsMap checksMap ignoredObservations [hieRelative]+              return (analysisToDiagnostics file analysis, Just ())+      else return ([], Nothing)++  action $ do+    files <- getFilesOfInterestUntracked+    void $ uses GetStanDiagnostics $ HM.keys files+  where+    analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic]+    analysisToDiagnostics file = mapMaybe (observationToDianostic file) . toList . analysisObservations+    observationToDianostic :: NormalizedFilePath -> Observation -> Maybe FileDiagnostic+    observationToDianostic file Observation {observationSrcSpan, observationInspectionId} =+      do+        inspection <- HM.lookup observationInspectionId inspectionsMap+        let+          -- Looking similar to Stan CLI output+          -- We do not use `prettyShowInspection` cuz Id is redundant here+          -- `prettyShowSeverity` and `prettyShowCategory` would contain color+          -- codes and are replaced, too+          message :: T.Text+          message =+            T.unlines $+              [ " ✲ Name:        " <> inspectionName inspection,+                " ✲ Description: " <> inspectionDescription inspection,+                " ✲ Severity:    " <> (T.pack $ show $ inspectionSeverity inspection),+                " ✲ Category:    " <> T.intercalate " "+                  (map (("#" <>) . unCategory) $ toList $ inspectionCategory inspection),+                "Possible solutions:"+              ]+                ++ map ("  - " <>) (inspectionSolution inspection)+        return ( file,+          ShowDiag,+          LSP.Diagnostic+            { _range = realSrcSpanToRange observationSrcSpan,+              _severity = Just LSP.DiagnosticSeverity_Hint,+              _code = Just (LSP.InR $ unId (inspectionId inspection)),+              _source = Just "stan",+              _message = message,+              _relatedInformation = Nothing,+              _tags = Nothing,+              _codeDescription = Nothing,+              _data_ = Nothing+            }+          )
+ plugins/hls-stan-plugin/test/Main.hs view
@@ -0,0 +1,78 @@+module Main+  ( main,+  )+where++import           Control.Lens               ((^.))+import qualified Data.Text                  as T+import qualified Ide.Plugin.Stan            as Stan+import           Ide.Types+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++tests :: TestTree+tests =+  testGroup+    "stan suggestions"+    [ testCase "provides diagnostics" $+        runStanSession "" $ do+          doc <- openDoc "test.hs" "haskell"+          diags@(reduceDiag : _) <- waitForDiagnosticsFromSource doc "stan"+          liftIO $ do+            length diags @?= 1+            reduceDiag ^. L.range @?= Range (Position 0 0) (Position 3 19)+            reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Hint+            let expectedPrefix = " ✲ Name:        "+            assertBool "" $ T.isPrefixOf expectedPrefix (reduceDiag ^. L.message)+            reduceDiag ^. L.source @?= Just "stan"+          return ()+    , testCase "ignores diagnostics from .stan.toml" $+        runStanSession "" $ do+          doc <- openDoc ("dir" </> "configTest.hs") "haskell"+          diags <- waitForDiagnosticsFromSource doc "stan"+          liftIO $ length diags @?= 0+          return ()+    , testCase "respects LANGUAGE pragmas in the source file" $+        runStanSession "" $ do+          doc <- openDoc ("extensions-language-pragma" </> "LanguagePragmaTest.hs") "haskell"+          diags <- waitForDiagnosticsFromSource doc "stan"+          -- We must include at least one valid diagnostic in our test file to avoid+          -- the false-positive case where Stan finds no analyses to perform due to a+          -- bad mapping, which would also lead to zero diagnostics being returned.+          liftIO $ length diags @?= 1+          return ()+    , testCase "respects language extensions defined in the .cabal file" $+        runStanSession "" $ do+          doc <- openDoc ("extensions-cabal-file" </> "CabalFileTest.hs") "haskell"+          diags <- waitForDiagnosticsFromSource doc "stan"+          -- We need at least one valid diagnostic here too, for the same reason as above.+          liftIO $ length diags @?= 1+          return ()+    ]++testDir :: FilePath+testDir = "plugins" </> "hls-stan-plugin" </> "test" </> "testdata"++stanPlugin :: PluginTestDescriptor Stan.Log+stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan"+  where+    -- We have to explicitly enable the plugin as it is disabled by default as+    -- per request: https://github.com/haskell/haskell-language-server/issues/3916+    --+    enabledStanDescriptor recorder plId =+      let stanPluginDescriptor = Stan.descriptor recorder plId+        in  stanPluginDescriptor+        { pluginConfigDescriptor = (pluginConfigDescriptor stanPluginDescriptor)+            { configInitialGenericConfig = (configInitialGenericConfig (pluginConfigDescriptor stanPluginDescriptor))+                { plcGlobalOn = True+                }+            }+        }++runStanSession :: FilePath -> Session a -> IO a+runStanSession subdir =+  failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir </> subdir)
+ plugins/hls-stan-plugin/test/testdata/dir/configTest.hs view
@@ -0,0 +1,3 @@+a = length [1..]++b = undefined
+ plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/CabalFileTest.hs view
@@ -0,0 +1,7 @@+module CabalFileTest () where++-- With `StrictData` enabled in the `.cabal` file, Stan shouldn't complain here:+data A = A Int Int++-- ...but it should still complain here!+kewlFunc = undefined
+ plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/cabal-file-test.cabal view
@@ -0,0 +1,9 @@+cabal-version: 3.0+name: cabal-file-test+version: 0.0.0.0++library+  exposed-modules: CabalFileTest+  hs-source-dirs: extensions-cabal-file+  -- Specifically, we're testing that Stan respects the following extension definition:+  default-extensions: StrictData
+ plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/LanguagePragmaTest.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE StrictData #-}++module LanguagePragmaTest () where++-- With the above `StrictData` language pragma, Stan shouldn't complain here:+data A = A Int Int++-- ...but it should still complain here!+kewlFunc = undefined
+ plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/language-pragma-test.cabal view
@@ -0,0 +1,11 @@+cabal-version: 3.0+name: language-pragma-test+version: 0.0.0.0++-- Without at least a minimal valid `.cabal` file, Stan won't bother building its+-- map of language extensions. This means it also won't detect LANGUAGE pragmas+-- without this file.++library+  exposed-modules: LanguagePragmaTest+  hs-source-dirs: extensions-language-pragma
+ plugins/hls-stan-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,4 @@+cradle:+  direct:+    arguments:+      - test.hs
+ plugins/hls-stan-plugin/test/testdata/test.hs view
@@ -0,0 +1,4 @@+orderPair x y+    | x < y = 1+    | x > y = 2+    | otherwise = 3
+ plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}+module Ide.Plugin.StylishHaskell+  ( descriptor+  , provider+  )+where++import           Control.Monad.Except             (throwError)+import           Control.Monad.IO.Class+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Development.IDE                  hiding (getExtensions,+                                                   pluginHandlers)+import           Development.IDE.Core.PluginUtils+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.Plugin.Error                 (PluginError (PluginInternalError))+import           Ide.PluginUtils+import           Ide.Types                        hiding (Config)+import           Language.Haskell.Stylish+import           Language.LSP.Protocol.Types      as LSP+import           System.Directory+import           System.FilePath++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId desc)+  { pluginHandlers = mkFormattingHandlers provider+  }+  where+    desc = "Provides formatting of Haskell files via stylish-haskell. Built with stylish-haskell-" <> VERSION_stylish_haskell++-- | Formatter provider of stylish-haskell.+-- Formats the given source in either a given Range or the whole Document.+-- If the provider fails an error is returned that can be displayed to the user.+provider :: FormattingHandler IdeState+provider ide _token typ contents fp _opts = do+  (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp+  let file = fromNormalizedFilePath fp+  config <- liftIO $ loadConfigFrom file+  mergedConfig <- liftIO $ getMergedConfig dyn config+  let (range, selectedContents) = case typ of+        FormatText    -> (fullRange contents, contents)+        FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents)+      result = runStylishHaskell file mergedConfig selectedContents+  case result of+    Left  err -> throwError $ PluginInternalError $ T.pack $ "stylishHaskellCmd: " ++ err+    Right new -> pure $ LSP.InL [TextEdit range new]+  where+    getMergedConfig dyn config+      | null (configLanguageExtensions config)+      = do+          logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags"+          pure+            $ config+              { configLanguageExtensions = getExtensions dyn }+      | otherwise+      = pure config++    getExtensions = map showExtension . Util.toList . extensionFlags++    showExtension Cpp   = "CPP"+    showExtension other = show other++-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.+-- If no such file has been found, return default config.+loadConfigFrom :: FilePath -> IO Config+loadConfigFrom file = do+  currDir <- getCurrentDirectory+  setCurrentDirectory (takeDirectory file)+  config <- loadConfig (makeVerbose False) Nothing+  setCurrentDirectory currDir+  pure config++-- | Run stylish-haskell on the given text with the given configuration.+runStylishHaskell :: FilePath           -- ^ Location of the file being formatted. Used for error message+                  -> Config             -- ^ Configuration for stylish-haskell+                  -> Text               -- ^ Text to format+                  -> Either String Text -- ^ Either formatted Text or an error message+runStylishHaskell file config = fmap fromLines . fmt . toLines+  where+    fromLines = T.pack . unlines+    fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config)+    toLines = lines . T.unpack
+ plugins/hls-stylish-haskell-plugin/test/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Main+  ( main+  ) where++import qualified Ide.Plugin.StylishHaskell as StylishHaskell+import           System.FilePath+import           Test.Hls++main :: IO ()+main = defaultTestRunner tests++stylishHaskellPlugin :: PluginTestDescriptor ()+stylishHaskellPlugin = mkPluginTestDescriptor' StylishHaskell.descriptor "stylishHaskell"++tests :: TestTree+tests = testGroup "stylish-haskell"+  [ goldenWithStylishHaskell "formats a document" "StylishHaskell" "formatted_document" $ \doc -> do+      formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing)+  , goldenWithStylishHaskell "formats a range" "StylishHaskell" "formatted_range" $ \doc -> do+      formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 0 0) (Position 2 21))+  ]++goldenWithStylishHaskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree+goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter def stylishHaskellPlugin "stylishHaskell" def title testDataDir fp desc "hs"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-stylish-haskell-plugin" </> "test" </> "testdata"
+ plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_document.hs view
@@ -0,0 +1,8 @@+import           Data.Char+import qualified Data.List+import           Data.String++bar :: Maybe (Either String Integer) -> Integer+bar Nothing          = 0+bar (Just (Left _))  = 0+bar (Just (Right x)) = x
+ plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_range.hs view
@@ -0,0 +1,8 @@+import           Data.Char+import qualified Data.List+import           Data.String++bar :: Maybe (Either String Integer) -> Integer+bar Nothing = 0+bar (Just (Left _)) = 0+bar (Just (Right x)) = x
+ plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.hs view
@@ -0,0 +1,8 @@+import Data.Char+import qualified Data.List+import    Data.String++bar :: Maybe (Either String Integer) -> Integer+bar Nothing = 0+bar (Just (Left _)) = 0+bar (Just (Right x)) = x
+ plugins/hls-stylish-haskell-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
src/HlsPlugins.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-} module HlsPlugins where  import           Ide.Logger                        (Pretty (pretty), Recorder,
src/Ide/Arguments.hs view
@@ -1,11 +1,9 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE CPP              #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above-{-# LANGUAGE TypeApplications #-}  module Ide.Arguments   ( Arguments(..)
src/Ide/Main.hs view
@@ -1,12 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE CPP                 #-}+{-# LANGUAGE CPP               #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}  module Ide.Main(defaultMain, runLspMode, Log(..)) where 
test/functional/Config.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeFamilies      #-} module Config (tests) where 
test/functional/Progress.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ViewPatterns          #-} module Progress (tests) where 
+ test/testdata/schema/ghc92/default-config.golden.json view
@@ -0,0 +1,141 @@+{+    "checkParents": "CheckOnSave",+    "checkProject": true,+    "formattingProvider": "ormolu",+    "maxCompletions": 40,+    "plugin": {+        "alternateNumberFormat": {+            "globalOn": true+        },+        "cabal": {+            "codeActionsOn": true,+            "completionOn": true,+            "diagnosticsOn": true+        },+        "callHierarchy": {+            "globalOn": true+        },+        "changeTypeSignature": {+            "globalOn": true+        },+        "class": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "eval": {+            "config": {+                "diff": true,+                "exception": false+            },+            "globalOn": true+        },+        "explicit-fields": {+            "globalOn": true+        },+        "explicit-fixity": {+            "globalOn": true+        },+        "fourmolu": {+            "config": {+                "external": false,+                "path": "fourmolu"+            }+        },+        "gadt": {+            "globalOn": true+        },+        "ghcide-code-actions-bindings": {+            "globalOn": true+        },+        "ghcide-code-actions-fill-holes": {+            "globalOn": true+        },+        "ghcide-code-actions-imports-exports": {+            "globalOn": true+        },+        "ghcide-code-actions-type-signatures": {+            "globalOn": true+        },+        "ghcide-completions": {+            "config": {+                "autoExtendOn": true,+                "snippetsOn": true+            },+            "globalOn": true+        },+        "ghcide-hover-and-symbols": {+            "hoverOn": true,+            "symbolsOn": true+        },+        "ghcide-type-lenses": {+            "config": {+                "mode": "always"+            },+            "globalOn": true+        },+        "hlint": {+            "codeActionsOn": true,+            "config": {+                "flags": []+            },+            "diagnosticsOn": true+        },+        "importLens": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "moduleName": {+            "globalOn": true+        },+        "ormolu": {+            "config": {+                "external": false+            }+        },+        "overloaded-record-dot": {+            "globalOn": true+        },+        "pragmas-completion": {+            "globalOn": true+        },+        "pragmas-disable": {+            "globalOn": true+        },+        "pragmas-suggest": {+            "globalOn": true+        },+        "qualifyImportedNames": {+            "globalOn": true+        },+        "rename": {+            "config": {+                "crossModule": false+            },+            "globalOn": true+        },+        "retrie": {+            "globalOn": true+        },+        "semanticTokens": {+            "config": {+                "classMethodToken": "method",+                "classToken": "class",+                "dataConstructorToken": "enumMember",+                "functionToken": "function",+                "moduleToken": "namespace",+                "operatorToken": "operator",+                "patternSynonymToken": "macro",+                "recordFieldToken": "property",+                "typeConstructorToken": "enum",+                "typeFamilyToken": "interface",+                "typeSynonymToken": "type",+                "typeVariableToken": "typeParameter",+                "variableToken": "variable"+            },+            "globalOn": false+        },+        "splice": {+            "globalOn": true+        }+    }+}
+ test/testdata/schema/ghc92/vscode-extension-schema.golden.json view
@@ -0,0 +1,1004 @@+{+    "haskell.plugin.alternateNumberFormat.globalOn": {+        "default": true,+        "description": "Enables alternateNumberFormat plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.codeActionsOn": {+        "default": true,+        "description": "Enables cabal code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.completionOn": {+        "default": true,+        "description": "Enables cabal completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.diagnosticsOn": {+        "default": true,+        "description": "Enables cabal diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.callHierarchy.globalOn": {+        "default": true,+        "description": "Enables callHierarchy plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.changeTypeSignature.globalOn": {+        "default": true,+        "description": "Enables changeTypeSignature plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeActionsOn": {+        "default": true,+        "description": "Enables class code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeLensOn": {+        "default": true,+        "description": "Enables class code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.diff": {+        "default": true,+        "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.exception": {+        "default": false,+        "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.globalOn": {+        "default": true,+        "description": "Enables eval plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fields.globalOn": {+        "default": true,+        "description": "Enables explicit-fields plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fixity.globalOn": {+        "default": true,+        "description": "Enables explicit-fixity plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.path": {+        "default": "fourmolu",+        "markdownDescription": "Set path to executable (for \"external\" mode).",+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.gadt.globalOn": {+        "default": true,+        "description": "Enables gadt plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-bindings.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-bindings plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-fill-holes plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-imports-exports plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-type-signatures plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.autoExtendOn": {+        "default": true,+        "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.snippetsOn": {+        "default": true,+        "markdownDescription": "Inserts snippets when using code completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.globalOn": {+        "default": true,+        "description": "Enables ghcide-completions plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.hoverOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols hover",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols symbols",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-type-lenses.config.mode": {+        "default": "always",+        "description": "Control how type lenses are shown",+        "enum": [+            "always",+            "exported",+            "diagnostics"+        ],+        "enumDescriptions": [+            "Always displays type lenses of global bindings",+            "Only display type lenses of exported global bindings",+            "Follows error messages produced by GHC about missing signatures"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.ghcide-type-lenses.globalOn": {+        "default": true,+        "description": "Enables ghcide-type-lenses plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.codeActionsOn": {+        "default": true,+        "description": "Enables hlint code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.config.flags": {+        "default": [],+        "markdownDescription": "Flags used by hlint",+        "scope": "resource",+        "type": "array"+    },+    "haskell.plugin.hlint.diagnosticsOn": {+        "default": true,+        "description": "Enables hlint diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeActionsOn": {+        "default": true,+        "description": "Enables importLens code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeLensOn": {+        "default": true,+        "description": "Enables importLens code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.moduleName.globalOn": {+        "default": true,+        "description": "Enables moduleName plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ormolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.overloaded-record-dot.globalOn": {+        "default": true,+        "description": "Enables overloaded-record-dot plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-completion.globalOn": {+        "default": true,+        "description": "Enables pragmas-completion plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-disable.globalOn": {+        "default": true,+        "description": "Enables pragmas-disable plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-suggest.globalOn": {+        "default": true,+        "description": "Enables pragmas-suggest plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.qualifyImportedNames.globalOn": {+        "default": true,+        "description": "Enables qualifyImportedNames plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.config.crossModule": {+        "default": false,+        "markdownDescription": "Enable experimental cross-module renaming",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.globalOn": {+        "default": true,+        "description": "Enables rename plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.retrie.globalOn": {+        "default": true,+        "description": "Enables retrie plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.semanticTokens.config.classMethodToken": {+        "default": "method",+        "description": "LSP semantic token type to use for typeclass methods",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.classToken": {+        "default": "class",+        "description": "LSP semantic token type to use for typeclasses",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.dataConstructorToken": {+        "default": "enumMember",+        "description": "LSP semantic token type to use for data constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.functionToken": {+        "default": "function",+        "description": "LSP semantic token type to use for functions",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.moduleToken": {+        "default": "namespace",+        "description": "LSP semantic token type to use for modules",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.operatorToken": {+        "default": "operator",+        "description": "LSP semantic token type to use for operators",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.patternSynonymToken": {+        "default": "macro",+        "description": "LSP semantic token type to use for pattern synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.recordFieldToken": {+        "default": "property",+        "description": "LSP semantic token type to use for record fields",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeConstructorToken": {+        "default": "enum",+        "description": "LSP semantic token type to use for type constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeFamilyToken": {+        "default": "interface",+        "description": "LSP semantic token type to use for type families",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeSynonymToken": {+        "default": "type",+        "description": "LSP semantic token type to use for type synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeVariableToken": {+        "default": "typeParameter",+        "description": "LSP semantic token type to use for type variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.variableToken": {+        "default": "variable",+        "description": "LSP semantic token type to use for variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.globalOn": {+        "default": false,+        "description": "Enables semanticTokens plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",+        "scope": "resource",+        "type": "boolean"+    }+}
+ test/testdata/schema/ghc94/default-config.golden.json view
@@ -0,0 +1,144 @@+{+    "checkParents": "CheckOnSave",+    "checkProject": true,+    "formattingProvider": "ormolu",+    "maxCompletions": 40,+    "plugin": {+        "alternateNumberFormat": {+            "globalOn": true+        },+        "cabal": {+            "codeActionsOn": true,+            "completionOn": true,+            "diagnosticsOn": true+        },+        "callHierarchy": {+            "globalOn": true+        },+        "changeTypeSignature": {+            "globalOn": true+        },+        "class": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "eval": {+            "config": {+                "diff": true,+                "exception": false+            },+            "globalOn": true+        },+        "explicit-fields": {+            "globalOn": true+        },+        "explicit-fixity": {+            "globalOn": true+        },+        "fourmolu": {+            "config": {+                "external": false,+                "path": "fourmolu"+            }+        },+        "gadt": {+            "globalOn": true+        },+        "ghcide-code-actions-bindings": {+            "globalOn": true+        },+        "ghcide-code-actions-fill-holes": {+            "globalOn": true+        },+        "ghcide-code-actions-imports-exports": {+            "globalOn": true+        },+        "ghcide-code-actions-type-signatures": {+            "globalOn": true+        },+        "ghcide-completions": {+            "config": {+                "autoExtendOn": true,+                "snippetsOn": true+            },+            "globalOn": true+        },+        "ghcide-hover-and-symbols": {+            "hoverOn": true,+            "symbolsOn": true+        },+        "ghcide-type-lenses": {+            "config": {+                "mode": "always"+            },+            "globalOn": true+        },+        "hlint": {+            "codeActionsOn": true,+            "config": {+                "flags": []+            },+            "diagnosticsOn": true+        },+        "importLens": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "moduleName": {+            "globalOn": true+        },+        "ormolu": {+            "config": {+                "external": false+            }+        },+        "overloaded-record-dot": {+            "globalOn": true+        },+        "pragmas-completion": {+            "globalOn": true+        },+        "pragmas-disable": {+            "globalOn": true+        },+        "pragmas-suggest": {+            "globalOn": true+        },+        "qualifyImportedNames": {+            "globalOn": true+        },+        "rename": {+            "config": {+                "crossModule": false+            },+            "globalOn": true+        },+        "retrie": {+            "globalOn": true+        },+        "semanticTokens": {+            "config": {+                "classMethodToken": "method",+                "classToken": "class",+                "dataConstructorToken": "enumMember",+                "functionToken": "function",+                "moduleToken": "namespace",+                "operatorToken": "operator",+                "patternSynonymToken": "macro",+                "recordFieldToken": "property",+                "typeConstructorToken": "enum",+                "typeFamilyToken": "interface",+                "typeSynonymToken": "type",+                "typeVariableToken": "typeParameter",+                "variableToken": "variable"+            },+            "globalOn": false+        },+        "splice": {+            "globalOn": true+        },+        "stan": {+            "globalOn": false+        }+    }+}
+ test/testdata/schema/ghc94/vscode-extension-schema.golden.json view
@@ -0,0 +1,1010 @@+{+    "haskell.plugin.alternateNumberFormat.globalOn": {+        "default": true,+        "description": "Enables alternateNumberFormat plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.codeActionsOn": {+        "default": true,+        "description": "Enables cabal code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.completionOn": {+        "default": true,+        "description": "Enables cabal completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.diagnosticsOn": {+        "default": true,+        "description": "Enables cabal diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.callHierarchy.globalOn": {+        "default": true,+        "description": "Enables callHierarchy plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.changeTypeSignature.globalOn": {+        "default": true,+        "description": "Enables changeTypeSignature plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeActionsOn": {+        "default": true,+        "description": "Enables class code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeLensOn": {+        "default": true,+        "description": "Enables class code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.diff": {+        "default": true,+        "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.exception": {+        "default": false,+        "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.globalOn": {+        "default": true,+        "description": "Enables eval plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fields.globalOn": {+        "default": true,+        "description": "Enables explicit-fields plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fixity.globalOn": {+        "default": true,+        "description": "Enables explicit-fixity plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.path": {+        "default": "fourmolu",+        "markdownDescription": "Set path to executable (for \"external\" mode).",+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.gadt.globalOn": {+        "default": true,+        "description": "Enables gadt plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-bindings.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-bindings plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-fill-holes plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-imports-exports plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-type-signatures plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.autoExtendOn": {+        "default": true,+        "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.snippetsOn": {+        "default": true,+        "markdownDescription": "Inserts snippets when using code completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.globalOn": {+        "default": true,+        "description": "Enables ghcide-completions plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.hoverOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols hover",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols symbols",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-type-lenses.config.mode": {+        "default": "always",+        "description": "Control how type lenses are shown",+        "enum": [+            "always",+            "exported",+            "diagnostics"+        ],+        "enumDescriptions": [+            "Always displays type lenses of global bindings",+            "Only display type lenses of exported global bindings",+            "Follows error messages produced by GHC about missing signatures"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.ghcide-type-lenses.globalOn": {+        "default": true,+        "description": "Enables ghcide-type-lenses plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.codeActionsOn": {+        "default": true,+        "description": "Enables hlint code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.config.flags": {+        "default": [],+        "markdownDescription": "Flags used by hlint",+        "scope": "resource",+        "type": "array"+    },+    "haskell.plugin.hlint.diagnosticsOn": {+        "default": true,+        "description": "Enables hlint diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeActionsOn": {+        "default": true,+        "description": "Enables importLens code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeLensOn": {+        "default": true,+        "description": "Enables importLens code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.moduleName.globalOn": {+        "default": true,+        "description": "Enables moduleName plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ormolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.overloaded-record-dot.globalOn": {+        "default": true,+        "description": "Enables overloaded-record-dot plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-completion.globalOn": {+        "default": true,+        "description": "Enables pragmas-completion plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-disable.globalOn": {+        "default": true,+        "description": "Enables pragmas-disable plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-suggest.globalOn": {+        "default": true,+        "description": "Enables pragmas-suggest plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.qualifyImportedNames.globalOn": {+        "default": true,+        "description": "Enables qualifyImportedNames plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.config.crossModule": {+        "default": false,+        "markdownDescription": "Enable experimental cross-module renaming",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.globalOn": {+        "default": true,+        "description": "Enables rename plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.retrie.globalOn": {+        "default": true,+        "description": "Enables retrie plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.semanticTokens.config.classMethodToken": {+        "default": "method",+        "description": "LSP semantic token type to use for typeclass methods",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.classToken": {+        "default": "class",+        "description": "LSP semantic token type to use for typeclasses",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.dataConstructorToken": {+        "default": "enumMember",+        "description": "LSP semantic token type to use for data constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.functionToken": {+        "default": "function",+        "description": "LSP semantic token type to use for functions",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.moduleToken": {+        "default": "namespace",+        "description": "LSP semantic token type to use for modules",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.operatorToken": {+        "default": "operator",+        "description": "LSP semantic token type to use for operators",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.patternSynonymToken": {+        "default": "macro",+        "description": "LSP semantic token type to use for pattern synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.recordFieldToken": {+        "default": "property",+        "description": "LSP semantic token type to use for record fields",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeConstructorToken": {+        "default": "enum",+        "description": "LSP semantic token type to use for type constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeFamilyToken": {+        "default": "interface",+        "description": "LSP semantic token type to use for type families",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeSynonymToken": {+        "default": "type",+        "description": "LSP semantic token type to use for type synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeVariableToken": {+        "default": "typeParameter",+        "description": "LSP semantic token type to use for type variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.variableToken": {+        "default": "variable",+        "description": "LSP semantic token type to use for variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.globalOn": {+        "default": false,+        "description": "Enables semanticTokens plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.stan.globalOn": {+        "default": false,+        "description": "Enables stan plugin",+        "scope": "resource",+        "type": "boolean"+    }+}
+ test/testdata/schema/ghc96/default-config.golden.json view
@@ -0,0 +1,144 @@+{+    "checkParents": "CheckOnSave",+    "checkProject": true,+    "formattingProvider": "ormolu",+    "maxCompletions": 40,+    "plugin": {+        "alternateNumberFormat": {+            "globalOn": true+        },+        "cabal": {+            "codeActionsOn": true,+            "completionOn": true,+            "diagnosticsOn": true+        },+        "callHierarchy": {+            "globalOn": true+        },+        "changeTypeSignature": {+            "globalOn": true+        },+        "class": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "eval": {+            "config": {+                "diff": true,+                "exception": false+            },+            "globalOn": true+        },+        "explicit-fields": {+            "globalOn": true+        },+        "explicit-fixity": {+            "globalOn": true+        },+        "fourmolu": {+            "config": {+                "external": false,+                "path": "fourmolu"+            }+        },+        "gadt": {+            "globalOn": true+        },+        "ghcide-code-actions-bindings": {+            "globalOn": true+        },+        "ghcide-code-actions-fill-holes": {+            "globalOn": true+        },+        "ghcide-code-actions-imports-exports": {+            "globalOn": true+        },+        "ghcide-code-actions-type-signatures": {+            "globalOn": true+        },+        "ghcide-completions": {+            "config": {+                "autoExtendOn": true,+                "snippetsOn": true+            },+            "globalOn": true+        },+        "ghcide-hover-and-symbols": {+            "hoverOn": true,+            "symbolsOn": true+        },+        "ghcide-type-lenses": {+            "config": {+                "mode": "always"+            },+            "globalOn": true+        },+        "hlint": {+            "codeActionsOn": true,+            "config": {+                "flags": []+            },+            "diagnosticsOn": true+        },+        "importLens": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "moduleName": {+            "globalOn": true+        },+        "ormolu": {+            "config": {+                "external": false+            }+        },+        "overloaded-record-dot": {+            "globalOn": true+        },+        "pragmas-completion": {+            "globalOn": true+        },+        "pragmas-disable": {+            "globalOn": true+        },+        "pragmas-suggest": {+            "globalOn": true+        },+        "qualifyImportedNames": {+            "globalOn": true+        },+        "rename": {+            "config": {+                "crossModule": false+            },+            "globalOn": true+        },+        "retrie": {+            "globalOn": true+        },+        "semanticTokens": {+            "config": {+                "classMethodToken": "method",+                "classToken": "class",+                "dataConstructorToken": "enumMember",+                "functionToken": "function",+                "moduleToken": "namespace",+                "operatorToken": "operator",+                "patternSynonymToken": "macro",+                "recordFieldToken": "property",+                "typeConstructorToken": "enum",+                "typeFamilyToken": "interface",+                "typeSynonymToken": "type",+                "typeVariableToken": "typeParameter",+                "variableToken": "variable"+            },+            "globalOn": false+        },+        "splice": {+            "globalOn": true+        },+        "stan": {+            "globalOn": false+        }+    }+}
+ test/testdata/schema/ghc96/vscode-extension-schema.golden.json view
@@ -0,0 +1,1010 @@+{+    "haskell.plugin.alternateNumberFormat.globalOn": {+        "default": true,+        "description": "Enables alternateNumberFormat plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.codeActionsOn": {+        "default": true,+        "description": "Enables cabal code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.completionOn": {+        "default": true,+        "description": "Enables cabal completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.diagnosticsOn": {+        "default": true,+        "description": "Enables cabal diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.callHierarchy.globalOn": {+        "default": true,+        "description": "Enables callHierarchy plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.changeTypeSignature.globalOn": {+        "default": true,+        "description": "Enables changeTypeSignature plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeActionsOn": {+        "default": true,+        "description": "Enables class code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeLensOn": {+        "default": true,+        "description": "Enables class code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.diff": {+        "default": true,+        "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.exception": {+        "default": false,+        "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.globalOn": {+        "default": true,+        "description": "Enables eval plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fields.globalOn": {+        "default": true,+        "description": "Enables explicit-fields plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fixity.globalOn": {+        "default": true,+        "description": "Enables explicit-fixity plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.path": {+        "default": "fourmolu",+        "markdownDescription": "Set path to executable (for \"external\" mode).",+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.gadt.globalOn": {+        "default": true,+        "description": "Enables gadt plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-bindings.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-bindings plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-fill-holes plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-imports-exports plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-type-signatures plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.autoExtendOn": {+        "default": true,+        "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.snippetsOn": {+        "default": true,+        "markdownDescription": "Inserts snippets when using code completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.globalOn": {+        "default": true,+        "description": "Enables ghcide-completions plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.hoverOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols hover",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols symbols",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-type-lenses.config.mode": {+        "default": "always",+        "description": "Control how type lenses are shown",+        "enum": [+            "always",+            "exported",+            "diagnostics"+        ],+        "enumDescriptions": [+            "Always displays type lenses of global bindings",+            "Only display type lenses of exported global bindings",+            "Follows error messages produced by GHC about missing signatures"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.ghcide-type-lenses.globalOn": {+        "default": true,+        "description": "Enables ghcide-type-lenses plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.codeActionsOn": {+        "default": true,+        "description": "Enables hlint code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.hlint.config.flags": {+        "default": [],+        "markdownDescription": "Flags used by hlint",+        "scope": "resource",+        "type": "array"+    },+    "haskell.plugin.hlint.diagnosticsOn": {+        "default": true,+        "description": "Enables hlint diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeActionsOn": {+        "default": true,+        "description": "Enables importLens code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeLensOn": {+        "default": true,+        "description": "Enables importLens code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.moduleName.globalOn": {+        "default": true,+        "description": "Enables moduleName plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ormolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.overloaded-record-dot.globalOn": {+        "default": true,+        "description": "Enables overloaded-record-dot plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-completion.globalOn": {+        "default": true,+        "description": "Enables pragmas-completion plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-disable.globalOn": {+        "default": true,+        "description": "Enables pragmas-disable plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-suggest.globalOn": {+        "default": true,+        "description": "Enables pragmas-suggest plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.qualifyImportedNames.globalOn": {+        "default": true,+        "description": "Enables qualifyImportedNames plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.config.crossModule": {+        "default": false,+        "markdownDescription": "Enable experimental cross-module renaming",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.globalOn": {+        "default": true,+        "description": "Enables rename plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.retrie.globalOn": {+        "default": true,+        "description": "Enables retrie plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.semanticTokens.config.classMethodToken": {+        "default": "method",+        "description": "LSP semantic token type to use for typeclass methods",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.classToken": {+        "default": "class",+        "description": "LSP semantic token type to use for typeclasses",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.dataConstructorToken": {+        "default": "enumMember",+        "description": "LSP semantic token type to use for data constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.functionToken": {+        "default": "function",+        "description": "LSP semantic token type to use for functions",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.moduleToken": {+        "default": "namespace",+        "description": "LSP semantic token type to use for modules",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.operatorToken": {+        "default": "operator",+        "description": "LSP semantic token type to use for operators",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.patternSynonymToken": {+        "default": "macro",+        "description": "LSP semantic token type to use for pattern synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.recordFieldToken": {+        "default": "property",+        "description": "LSP semantic token type to use for record fields",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeConstructorToken": {+        "default": "enum",+        "description": "LSP semantic token type to use for type constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeFamilyToken": {+        "default": "interface",+        "description": "LSP semantic token type to use for type families",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeSynonymToken": {+        "default": "type",+        "description": "LSP semantic token type to use for type synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeVariableToken": {+        "default": "typeParameter",+        "description": "LSP semantic token type to use for type variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.variableToken": {+        "default": "variable",+        "description": "LSP semantic token type to use for variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.globalOn": {+        "default": false,+        "description": "Enables semanticTokens plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.stan.globalOn": {+        "default": false,+        "description": "Enables stan plugin",+        "scope": "resource",+        "type": "boolean"+    }+}
+ test/testdata/schema/ghc98/default-config.golden.json view
@@ -0,0 +1,137 @@+{+    "checkParents": "CheckOnSave",+    "checkProject": true,+    "formattingProvider": "ormolu",+    "maxCompletions": 40,+    "plugin": {+        "alternateNumberFormat": {+            "globalOn": true+        },+        "cabal": {+            "codeActionsOn": true,+            "completionOn": true,+            "diagnosticsOn": true+        },+        "callHierarchy": {+            "globalOn": true+        },+        "changeTypeSignature": {+            "globalOn": true+        },+        "class": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "eval": {+            "config": {+                "diff": true,+                "exception": false+            },+            "globalOn": true+        },+        "explicit-fields": {+            "globalOn": true+        },+        "explicit-fixity": {+            "globalOn": true+        },+        "fourmolu": {+            "config": {+                "external": false,+                "path": "fourmolu"+            }+        },+        "gadt": {+            "globalOn": true+        },+        "ghcide-code-actions-bindings": {+            "globalOn": true+        },+        "ghcide-code-actions-fill-holes": {+            "globalOn": true+        },+        "ghcide-code-actions-imports-exports": {+            "globalOn": true+        },+        "ghcide-code-actions-type-signatures": {+            "globalOn": true+        },+        "ghcide-completions": {+            "config": {+                "autoExtendOn": true,+                "snippetsOn": true+            },+            "globalOn": true+        },+        "ghcide-hover-and-symbols": {+            "hoverOn": true,+            "symbolsOn": true+        },+        "ghcide-type-lenses": {+            "config": {+                "mode": "always"+            },+            "globalOn": true+        },+        "importLens": {+            "codeActionsOn": true,+            "codeLensOn": true+        },+        "moduleName": {+            "globalOn": true+        },+        "ormolu": {+            "config": {+                "external": false+            }+        },+        "overloaded-record-dot": {+            "globalOn": true+        },+        "pragmas-completion": {+            "globalOn": true+        },+        "pragmas-disable": {+            "globalOn": true+        },+        "pragmas-suggest": {+            "globalOn": true+        },+        "qualifyImportedNames": {+            "globalOn": true+        },+        "rename": {+            "config": {+                "crossModule": false+            },+            "globalOn": true+        },+        "retrie": {+            "globalOn": true+        },+        "semanticTokens": {+            "config": {+                "classMethodToken": "method",+                "classToken": "class",+                "dataConstructorToken": "enumMember",+                "functionToken": "function",+                "moduleToken": "namespace",+                "operatorToken": "operator",+                "patternSynonymToken": "macro",+                "recordFieldToken": "property",+                "typeConstructorToken": "enum",+                "typeFamilyToken": "interface",+                "typeSynonymToken": "type",+                "typeVariableToken": "typeParameter",+                "variableToken": "variable"+            },+            "globalOn": false+        },+        "splice": {+            "globalOn": true+        },+        "stan": {+            "globalOn": false+        }+    }+}
+ test/testdata/schema/ghc98/vscode-extension-schema.golden.json view
@@ -0,0 +1,992 @@+{+    "haskell.plugin.alternateNumberFormat.globalOn": {+        "default": true,+        "description": "Enables alternateNumberFormat plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.codeActionsOn": {+        "default": true,+        "description": "Enables cabal code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.completionOn": {+        "default": true,+        "description": "Enables cabal completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.cabal.diagnosticsOn": {+        "default": true,+        "description": "Enables cabal diagnostics",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.callHierarchy.globalOn": {+        "default": true,+        "description": "Enables callHierarchy plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.changeTypeSignature.globalOn": {+        "default": true,+        "description": "Enables changeTypeSignature plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeActionsOn": {+        "default": true,+        "description": "Enables class code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.class.codeLensOn": {+        "default": true,+        "description": "Enables class code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.diff": {+        "default": true,+        "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.config.exception": {+        "default": false,+        "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.eval.globalOn": {+        "default": true,+        "description": "Enables eval plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fields.globalOn": {+        "default": true,+        "description": "Enables explicit-fields plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.explicit-fixity.globalOn": {+        "default": true,+        "description": "Enables explicit-fixity plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.path": {+        "default": "fourmolu",+        "markdownDescription": "Set path to executable (for \"external\" mode).",+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.gadt.globalOn": {+        "default": true,+        "description": "Enables gadt plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-bindings.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-bindings plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-fill-holes plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-imports-exports plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": {+        "default": true,+        "description": "Enables ghcide-code-actions-type-signatures plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.autoExtendOn": {+        "default": true,+        "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.config.snippetsOn": {+        "default": true,+        "markdownDescription": "Inserts snippets when using code completions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-completions.globalOn": {+        "default": true,+        "description": "Enables ghcide-completions plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.hoverOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols hover",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": {+        "default": true,+        "description": "Enables ghcide-hover-and-symbols symbols",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ghcide-type-lenses.config.mode": {+        "default": "always",+        "description": "Control how type lenses are shown",+        "enum": [+            "always",+            "exported",+            "diagnostics"+        ],+        "enumDescriptions": [+            "Always displays type lenses of global bindings",+            "Only display type lenses of exported global bindings",+            "Follows error messages produced by GHC about missing signatures"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.ghcide-type-lenses.globalOn": {+        "default": true,+        "description": "Enables ghcide-type-lenses plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeActionsOn": {+        "default": true,+        "description": "Enables importLens code actions",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.importLens.codeLensOn": {+        "default": true,+        "description": "Enables importLens code lenses",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.moduleName.globalOn": {+        "default": true,+        "description": "Enables moduleName plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.ormolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.overloaded-record-dot.globalOn": {+        "default": true,+        "description": "Enables overloaded-record-dot plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-completion.globalOn": {+        "default": true,+        "description": "Enables pragmas-completion plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-disable.globalOn": {+        "default": true,+        "description": "Enables pragmas-disable plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.pragmas-suggest.globalOn": {+        "default": true,+        "description": "Enables pragmas-suggest plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.qualifyImportedNames.globalOn": {+        "default": true,+        "description": "Enables qualifyImportedNames plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.config.crossModule": {+        "default": false,+        "markdownDescription": "Enable experimental cross-module renaming",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.rename.globalOn": {+        "default": true,+        "description": "Enables rename plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.retrie.globalOn": {+        "default": true,+        "description": "Enables retrie plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.semanticTokens.config.classMethodToken": {+        "default": "method",+        "description": "LSP semantic token type to use for typeclass methods",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.classToken": {+        "default": "class",+        "description": "LSP semantic token type to use for typeclasses",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.dataConstructorToken": {+        "default": "enumMember",+        "description": "LSP semantic token type to use for data constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.functionToken": {+        "default": "function",+        "description": "LSP semantic token type to use for functions",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.moduleToken": {+        "default": "namespace",+        "description": "LSP semantic token type to use for modules",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.operatorToken": {+        "default": "operator",+        "description": "LSP semantic token type to use for operators",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.patternSynonymToken": {+        "default": "macro",+        "description": "LSP semantic token type to use for pattern synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.recordFieldToken": {+        "default": "property",+        "description": "LSP semantic token type to use for record fields",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeConstructorToken": {+        "default": "enum",+        "description": "LSP semantic token type to use for type constructors",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeFamilyToken": {+        "default": "interface",+        "description": "LSP semantic token type to use for type families",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeSynonymToken": {+        "default": "type",+        "description": "LSP semantic token type to use for type synonyms",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.typeVariableToken": {+        "default": "typeParameter",+        "description": "LSP semantic token type to use for type variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.config.variableToken": {+        "default": "variable",+        "description": "LSP semantic token type to use for variables",+        "enum": [+            "namespace",+            "type",+            "class",+            "enum",+            "interface",+            "struct",+            "typeParameter",+            "parameter",+            "variable",+            "property",+            "enumMember",+            "event",+            "function",+            "method",+            "macro",+            "keyword",+            "modifier",+            "comment",+            "string",+            "number",+            "regexp",+            "operator",+            "decorator"+        ],+        "enumDescriptions": [+            "LSP Semantic Token Type: namespace",+            "LSP Semantic Token Type: type",+            "LSP Semantic Token Type: class",+            "LSP Semantic Token Type: enum",+            "LSP Semantic Token Type: interface",+            "LSP Semantic Token Type: struct",+            "LSP Semantic Token Type: typeParameter",+            "LSP Semantic Token Type: parameter",+            "LSP Semantic Token Type: variable",+            "LSP Semantic Token Type: property",+            "LSP Semantic Token Type: enumMember",+            "LSP Semantic Token Type: event",+            "LSP Semantic Token Type: function",+            "LSP Semantic Token Type: method",+            "LSP Semantic Token Type: macro",+            "LSP Semantic Token Type: keyword",+            "LSP Semantic Token Type: modifier",+            "LSP Semantic Token Type: comment",+            "LSP Semantic Token Type: string",+            "LSP Semantic Token Type: number",+            "LSP Semantic Token Type: regexp",+            "LSP Semantic Token Type: operator",+            "LSP Semantic Token Type: decorator"+        ],+        "scope": "resource",+        "type": "string"+    },+    "haskell.plugin.semanticTokens.globalOn": {+        "default": false,+        "description": "Enables semanticTokens plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.stan.globalOn": {+        "default": false,+        "description": "Enables stan plugin",+        "scope": "resource",+        "type": "boolean"+    }+}