haskell-language-server 2.11.0.0 → 2.12.0.0
raw patch · 136 files changed
+4452/−3112 lines, 136 filesdep +markdown-unlitdep +string-interpolatedep −hie-compatdep ~Diffdep ~basedep ~cabal-addnew-component:exe:plugin-tutorialPVP ok
version bump matches the API change (PVP)
Dependencies added: markdown-unlit, string-interpolate
Dependencies removed: hie-compat
Dependency ranges changed: Diff, base, cabal-add, fourmolu, ghcide, hiedb, hls-graph, hls-plugin-api, hls-test-utils, lsp, lsp-types, mtl, stan, unordered-containers
API changes (from Hackage documentation)
+ Ide.Arguments: PluginsCustomConfigMarkdownReferenceMode :: Arguments
Files
- ChangeLog.md +114/−0
- docs/contributing/plugin-tutorial.lhs +418/−0
- exe/Wrapper.hs +8/−2
- ghcide-test/data/references/Fields.hs +18/−0
- ghcide-test/data/references/Main.hs +4/−1
- ghcide-test/data/references/hie.yaml +1/−1
- ghcide-test/exe/CodeLensTests.hs +59/−38
- ghcide-test/exe/CompletionTests.hs +38/−7
- ghcide-test/exe/CradleTests.hs +11/−6
- ghcide-test/exe/DependentFileTest.hs +3/−2
- ghcide-test/exe/DiagnosticTests.hs +6/−18
- ghcide-test/exe/FindDefinitionAndHoverTests.hs +4/−3
- ghcide-test/exe/GarbageCollectionTests.hs +6/−5
- ghcide-test/exe/IfaceTests.hs +2/−1
- ghcide-test/exe/PluginSimpleTests.hs +2/−1
- ghcide-test/exe/ReferenceTests.hs +27/−5
- ghcide-test/exe/UnitTests.hs +3/−2
- ghcide-test/exe/WatchedFileTests.hs +6/−6
- haskell-language-server.cabal +209/−113
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +167/−322
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs +0/−326
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs +343/−0
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs +232/−0
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Types.hs +104/−0
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Files.hs +56/−0
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs +122/−0
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs +16/−1
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs +2/−2
- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs +160/−0
- plugins/hls-cabal-plugin/test/CabalAdd.hs +100/−45
- plugins/hls-cabal-plugin/test/Completer.hs +30/−30
- plugins/hls-cabal-plugin/test/Context.hs +64/−64
- plugins/hls-cabal-plugin/test/Main.hs +75/−9
- plugins/hls-cabal-plugin/test/Utils.hs +9/−0
- plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/Main.hs +4/−0
- plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/cabal.project +1/−0
- plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/hie.yaml +2/−0
- plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/test.cabal +26/−0
- plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs +9/−0
- plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project +1/−0
- plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml +2/−0
- plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal +14/−0
- plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +6/−0
- plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +133/−52
- plugins/hls-change-type-signature-plugin/test/Main.hs +18/−42
- plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt +8/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.txt +8/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.txt +4/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.txt +9/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt +5/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt +6/−0
- plugins/hls-change-type-signature-plugin/test/testdata/error1.txt +0/−6
- plugins/hls-change-type-signature-plugin/test/testdata/error2.txt +0/−6
- plugins/hls-change-type-signature-plugin/test/testdata/error3.txt +0/−10
- plugins/hls-change-type-signature-plugin/test/testdata/error4.txt +0/−19
- plugins/hls-change-type-signature-plugin/test/testdata/error5.txt +0/−15
- plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +38/−45
- plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +1/−3
- plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +4/−4
- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +5/−1
- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +3/−4
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +1/−1
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +8/−11
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +0/−4
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +0/−2
- plugins/hls-eval-plugin/test/Main.hs +2/−4
- plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs +0/−4
- plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs +8/−0
- plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +0/−18
- plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +50/−18
- plugins/hls-explicit-record-fields-plugin/test/Main.hs +54/−0
- plugins/hls-explicit-record-fields-plugin/test/testdata/ConstructionDuplicateRecordFields.hs +17/−0
- plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1DuplicateRecordFields.hs +19/−0
- plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstructionDuplicateRecordFields.hs +17/−0
- plugins/hls-explicit-record-fields-plugin/test/testdata/noop/PartiallyAppliedCon.hs +8/−0
- plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +4/−11
- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +30/−22
- plugins/hls-hlint-plugin/test/Main.hs +15/−20
- plugins/hls-hlint-plugin/test/testdata/IgnoreHintAction.expected.hs +3/−0
- plugins/hls-hlint-plugin/test/testdata/IgnoreHintAction.hs +2/−0
- plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs +0/−4
- plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs +0/−3
- plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs +0/−5
- plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs +0/−3
- plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +86/−32
- plugins/hls-notes-plugin/test/NotesTest.hs +19/−3
- plugins/hls-notes-plugin/test/testdata/NoteDef.hs +3/−0
- plugins/hls-notes-plugin/test/testdata/Other.hs +1/−0
- plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +61/−13
- plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +5/−5
- plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +4/−8
- plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +0/−22
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +21/−141
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +43/−34
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +24/−81
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs +2/−0
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +19/−26
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs +80/−52
- plugins/hls-refactor-plugin/test/Main.hs +68/−52
- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +30/−9
- plugins/hls-rename-plugin/test/Main.hs +6/−1
- plugins/hls-rename-plugin/test/testdata/DataConstructorWithFields.expected.hs +14/−0
- plugins/hls-rename-plugin/test/testdata/DataConstructorWithFields.hs +14/−0
- plugins/hls-rename-plugin/test/testdata/DataConstructorWithFieldsRecordWildcards.expected.hs +5/−0
- plugins/hls-rename-plugin/test/testdata/DataConstructorWithFieldsRecordWildcards.hs +5/−0
- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +0/−10
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +3/−0
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +4/−0
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +3/−0
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs +2/−2
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs +4/−0
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +3/−3
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs +5/−0
- plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs +345/−0
- plugins/hls-signature-help-plugin/test/Main.hs +514/−0
- plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +3/−43
- plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +1/−1
- src/HlsPlugins.hs +8/−2
- src/Ide/Arguments.hs +5/−0
- src/Ide/Main.hs +5/−1
- test/functional/ConfigSchema.hs +9/−0
- test/testdata/hieBiosError/hie.yaml +0/−0
- test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json +1/−0
- test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json +1/−0
- test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json +1/−1
- test/testdata/schema/ghc910/default-config.golden.json +10/−0
- test/testdata/schema/ghc910/vscode-extension-schema.golden.json +24/−0
- test/testdata/schema/ghc912/default-config.golden.json +3/−0
- test/testdata/schema/ghc912/vscode-extension-schema.golden.json +6/−0
- test/testdata/schema/ghc94/default-config.golden.json +0/−164
- test/testdata/schema/ghc94/vscode-extension-schema.golden.json +0/−1058
- test/testdata/schema/ghc96/default-config.golden.json +3/−0
- test/testdata/schema/ghc96/vscode-extension-schema.golden.json +6/−0
- test/testdata/schema/ghc98/default-config.golden.json +3/−0
- test/testdata/schema/ghc98/vscode-extension-schema.golden.json +6/−0
- test/testdata/wErrorTest/dist-newstyle/cache/plan.json +0/−1
ChangeLog.md view
@@ -1,5 +1,119 @@ # Changelog for haskell-language-server +## 2.12.0.0++- Bindists for GHC 9.12.2+- Bindists for GHC 9.10.3+- Bindists for GHC 9.8.4+- Bindists for GHC 9.6.7+- Dropped support for GHC 9.4+- Dropped binaries for Debian 9+- Added binaries for Debian 13++### Pull Requests++- Fix warning for `-Werror` build in Circle CI+ ([#4727](https://github.com/haskell/haskell-language-server/pull/4727)) by @fendor+- Replace neat-interpolation with string-interpolate+ ([#4717](https://github.com/haskell/haskell-language-server/pull/4717)) by @jian-lin+- Document how to set formattingProvider in emacs, modern syntax+ ([#4713](https://github.com/haskell/haskell-language-server/pull/4713)) by @unhammer+- Replace writeFile with atomicFileWrite in ghcide-tests+ ([#4710](https://github.com/haskell/haskell-language-server/pull/4710)) by @soulomoon+- #4705 Fix flaky test `bidirectional module dependency with hs-boot`+ ([#4706](https://github.com/haskell/haskell-language-server/pull/4706)) by @soulomoon+- Refactor CoreFile to use fat interface core type+ ([#4700](https://github.com/haskell/haskell-language-server/pull/4700)) by @soulomoon+- Support fourmolu 0.19.0.0+ ([#4693](https://github.com/haskell/haskell-language-server/pull/4693)) by @brandonchinn178+- Bump CI to GHC 9.10.2+ ([#4687](https://github.com/haskell/haskell-language-server/pull/4687)) by @fendor+- Upgrade to hie-bios 0.17.0+ ([#4686](https://github.com/haskell/haskell-language-server/pull/4686)) by @fendor+- Fix build with GHC 9.10.3-rc1+ ([#4679](https://github.com/haskell/haskell-language-server/pull/4679)) by @andreasabel+- Use plain comments instead of annotations for HLint ignores+ ([#4669](https://github.com/haskell/haskell-language-server/pull/4669)) by @georgefst+- Use structured diagnostics for type wildcard fill suggestions+ ([#4664](https://github.com/haskell/haskell-language-server/pull/4664)) by @sgillespie+- concurrency bug fixes/ improvements+ ([#4663](https://github.com/haskell/haskell-language-server/pull/4663)) by @MangoIV+- Show LaTeX math expressions in haddockToMarkdown+ ([#4658](https://github.com/haskell/haskell-language-server/pull/4658)) by @webdevred+- Mangoiv/improve key business+ ([#4654](https://github.com/haskell/haskell-language-server/pull/4654)) by @MangoIV+- hls-cabal-plugin: Fix cabal-add bound (#4642)+ ([#4652](https://github.com/haskell/haskell-language-server/pull/4652)) by @wz1000+- fix: add context code action with trailing comment+ ([#4649](https://github.com/haskell/haskell-language-server/pull/4649)) by @guibou+- Use hie-bios 0.16+ ([#4647](https://github.com/haskell/haskell-language-server/pull/4647)) by @fendor+- Fix build for GHC 9.10.2+ ([#4644](https://github.com/haskell/haskell-language-server/pull/4644)) by @sgillespie+- Add tests for references to record fields and update symbol retrieval to only include source nodes+ ([#4641](https://github.com/haskell/haskell-language-server/pull/4641)) by @soulomoon+- Bump up hiedb version #4639+ ([#4640](https://github.com/haskell/haskell-language-server/pull/4640)) by @soulomoon+- CI: Fix hls-eval-plugin tests for GHC-9.10+ ([#4638](https://github.com/haskell/haskell-language-server/pull/4638)) by @sgillespie+- Fix renaming data constructors with fields (resolves #2915, resolves #4083) + ([#4635](https://github.com/haskell/haskell-language-server/pull/4635)) by @jhrcek+- Migrate change-type-signature-plugin to use structured diagnostics+ ([#4632](https://github.com/haskell/haskell-language-server/pull/4632)) by @sgillespie+- Reload .cabal files when they are modified+ ([#4630](https://github.com/haskell/haskell-language-server/pull/4630)) by @fendor+- Set the diagnostic code description on GHC diagnostics+ ([#4629](https://github.com/haskell/haskell-language-server/pull/4629)) by @michaelpj+- Ensure usage of stan-0.2.1.0 to fix #4515+ ([#4628](https://github.com/haskell/haskell-language-server/pull/4628)) by @0rphee+- Implement signature help+ ([#4626](https://github.com/haskell/haskell-language-server/pull/4626)) by @jian-lin+- Start using structured diagnostics for missing signatures+ ([#4625](https://github.com/haskell/haskell-language-server/pull/4625)) by @janvogt+- hls-notes-plugin: Allow to see where a note is referenced from+ ([#4624](https://github.com/haskell/haskell-language-server/pull/4624)) by @jvanbruegge+- Revert "Switch ghcide tests to sequential execution (#4307)"+ ([#4623](https://github.com/haskell/haskell-language-server/pull/4623)) by @fendor+- Use structured diagnostics in pragmas plugin+ ([#4620](https://github.com/haskell/haskell-language-server/pull/4620)) by @dyniec+- Fix completion for record dot syntax when record isn't known+ ([#4619](https://github.com/haskell/haskell-language-server/pull/4619)) by @samuel-williams-da+- Add Code Action for adding a module to your project's cabal file+ ([#4617](https://github.com/haskell/haskell-language-server/pull/4617)) by @VeryMilkyJoe+- Support hlint on 9.10 apart from apply-refact+ ([#4616](https://github.com/haskell/haskell-language-server/pull/4616)) by @michaelpj+- Remove `hie-compat`+ ([#4613](https://github.com/haskell/haskell-language-server/pull/4613)) by @dschrempf+- allow Diff 1.x+ ([#4608](https://github.com/haskell/haskell-language-server/pull/4608)) by @peterbecich+- provide `curl` in dev shell+ ([#4607](https://github.com/haskell/haskell-language-server/pull/4607)) by @peterbecich+- Fix minor typo in Eval plugin descriptor+ ([#4597](https://github.com/haskell/haskell-language-server/pull/4597)) by @joe-warren+- Avoid unnecessary recompilation due to -haddock+ ([#4596](https://github.com/haskell/haskell-language-server/pull/4596)) by @fendor+- Compute Partial module graph fingerprints+ ([#4594](https://github.com/haskell/haskell-language-server/pull/4594)) by @soulomoon+- Strip prefixes added by DuplicateRecordFields + ([#4593](https://github.com/haskell/haskell-language-server/pull/4593)) by @kozak+- Use shorter test names in ghcide-tests+ ([#4591](https://github.com/haskell/haskell-language-server/pull/4591)) by @fendor+- Bump haskell-actions/setup from 2.7.11 to 2.8.0+ ([#4589](https://github.com/haskell/haskell-language-server/pull/4589)) by @dependabot[bot]+- Only expand positional records if the DataCon application is fully saturated+ ([#4586](https://github.com/haskell/haskell-language-server/pull/4586)) by @ozkutuk+- Prepare release 2.11.0.0+ ([#4585](https://github.com/haskell/haskell-language-server/pull/4585)) by @wz1000+- Plugin tutorial, more changes+ ([#4570](https://github.com/haskell/haskell-language-server/pull/4570)) by @dschrempf+- Cleanup CPPs, remove support for GHC 9.4+ ([#4567](https://github.com/haskell/haskell-language-server/pull/4567)) by @dschrempf+- Migrate `hls-class-plugin` to use structured diagnostics+ ([#4472](https://github.com/haskell/haskell-language-server/pull/4472)) by @fendor+- Generate custom parameters' documentation for plugins+ ([#4414](https://github.com/haskell/haskell-language-server/pull/4414)) by @develop7+- Switch ghcide tests to sequential execution+ ([#4307](https://github.com/haskell/haskell-language-server/pull/4307)) by @dyniec ## 2.11.0.0
+ docs/contributing/plugin-tutorial.lhs view
@@ -0,0 +1,418 @@+# Let’s write a Haskell Language Server plugin++Originally written by Pepe Iborra, maintained by the Haskell community.++Haskell Language Server (HLS) is a Language Server Protocol (LSP) server for the Haskell programming language. It builds on several previous efforts to create a Haskell IDE.+You can find many more details on the history and architecture on the [IDE 2020](https://mpickering.github.io/ide/index.html) community page.+In this article we are going to cover the creation of an HLS plugin from scratch: a code lens to display explicit import lists.+Along the way we will learn about HLS, its plugin model, and the relationship with [ghcide](https://github.com/haskell/haskell-language-server/tree/master/ghcide) and LSP.++## Introduction++Writing plugins for HLS is a joy. Personally, I enjoy the ability to tap into the gigantic bag of goodies that is GHC, as well as the IDE integration thanks to LSP.++In the last couple of months, I have written various HLS plugins, including:++1. Suggest imports for variables not in scope,+2. Remove redundant imports,+3. Evaluate code in comments (à la [doctest](https://docs.python.org/3/library/doctest.html)),+4. Integrate the [retrie](https://github.com/facebookincubator/retrie) refactoring library.++These plugins are small but meaningful steps towards a more polished IDE experience.+While writing them, I didn't have to worry about performance, UI, or distribution; another tool (usually GHC) always did the heavy lifting.++The plugins also make these tools much more accessible to all users of HLS.++## Preamble++This tutorial is a literate Haskell file that can be compiled.+As such, we list the imports, extensions etc... necessary for compilation.++Please just skip over this `import` section, if you are only interested in the tutorial!++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}++import Ide.Types+import Ide.Logger+import Ide.Plugin.Error++import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Service hiding (Log)+import Development.IDE.Core.Shake hiding (Log)+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Error+import Development.IDE.Types.HscEnvEq+import Development.IDE.Core.PluginUtils++import qualified Language.LSP.Server as LSP+import Language.LSP.Protocol.Types as JL+import Language.LSP.Protocol.Message++import Data.Aeson as Aeson+import Data.Map (Map)+import Data.IORef+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import Control.Monad (forM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class+import GHC.Generics (Generic)+```++## Plugins in the HLS codebase++The HLS codebase includes several plugins (found in `./plugins`). For example:++- The `ormolu`, `fourmolu`, `floskell` and `stylish-haskell` plugins used to format code+- The `eval` plugin, a code lens provider to evaluate code in comments+- The `retrie` plugin, a code action provider to execute retrie commands++I recommend looking at the existing plugins for inspiration and reference. A few conventions shared by all plugins are:++- Plugins are in the `./plugins` folder+- Plugins implement their code under the `Ide.Plugin.*` namespace+- Folders containing the plugin follow the `hls-pluginname-plugin` naming convention+- Plugins are "linked" in `src/HlsPlugins.hs#idePlugins`. New plugin descriptors+ must be added there.++ ```haskell ignore+ -- Defined in src/HlsPlugins.**hs**++ idePlugins = pluginDescToIdePlugins allPlugins+ where+ allPlugins =+ [ GhcIde.descriptor "ghcide"+ , Pragmas.descriptor "pragmas"+ , Floskell.descriptor "floskell"+ , Fourmolu.descriptor "fourmolu"+ , Ormolu.descriptor "ormolu"+ , StylishHaskell.descriptor "stylish-haskell"+ , Retrie.descriptor "retrie"+ , Eval.descriptor "eval"+ , NewPlugin.descriptor "new-plugin" -- Add new plugins here.+ ]+ ```++To add a new plugin, extend the list of `allPlugins` and rebuild.++## The goal of the plugin we will write++Here is a visual statement of what we want to accomplish:++ ++And here is the gist of the algorithm:++1. Request the type checking artifacts from the `ghcide` subsystem+2. Extract the actual import lists from the type-checked AST+3. Ask GHC to produce the minimal import lists for this AST+4. For every import statement without an explicit import list:+ - Determine the minimal import list+ - Produce a code lens to display it and a command to apply it++## Setup++To get started, fetch the HLS repository and build it by following the [installation instructions](https://haskell-language-server.readthedocs.io/en/latest/contributing/contributing.html#building).++If you run into any issues trying to build the binaries, you can get in touch with the HLS team using one of the [contact channels](https://haskell-language-server.readthedocs.io/en/latest/contributing/contributing.html#how-to-contact-the-haskell-ide-team) or [open an issue](https://github.com/haskell/haskell-language-server/issues) in the HLS repository.++Once the build is done, you can find the location of the HLS binary with `cabal list-bin exe:haskell-language-server` and point your LSP client to it.+This way you can simply test your changes by reloading your editor after rebuilding the binary.++> **Note:** In VSCode, edit the "Haskell Server Executable Path" setting.+>+> **Note:** In Emacs, edit the `lsp-haskell-server-path` variable.++++[Manually test your hacked HLS](https://haskell-language-server.readthedocs.io/en/latest/contributing/contributing.html#manually-testing-your-hacked-hls) to ensure you use the HLS package you just built.++## Digression about the Language Server Protocol++There are two main types of communication in the Language Server Protocol:++- A **request-response interaction** type where one party sends a message that requires a response from the other party.+- A **notification** is a one-way interaction where one party sends a message without expecting any response.++> **Note**: The LSP client and server can both send requests or notifications to the other party.++## Anatomy of a plugin++HLS plugins are values of the `PluginDescriptor` datatype, which is defined in `hls-plugin-api/src/Ide/Types.hs` as:++```haskell ignore+data PluginDescriptor (ideState :: Type) =+ PluginDescriptor { pluginId :: !PluginId+ , pluginCommands :: ![PluginCommand ideState]+ , pluginHandlers :: PluginHandlers ideState+ , pluginNotificationHandlers :: PluginNotificationHandlers ideState+-- , [...] -- Other fields omitted for brevity.+ }+```++### Request-response interaction++The `pluginHandlers` handle LSP client requests and provide responses to the client. They must fulfill these requests as quickly as possible.++- Example: When you want to format a file, the client sends the [`textDocument/formatting`](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_formatting) request to the server. The server formats the file and responds with the formatted content.++### Notification++The `pluginNotificationHandlers` handle notifications sent by the client to the server that are not explicitly triggered by a user.++- Example: Whenever you modify a Haskell file, the client sends a notification informing HLS about the changes to the file.++The `pluginCommands` are special types of user-initiated notifications sent to+the server. These actions can be long-running and involve multiple modules.++## The explicit imports plugin++To achieve our plugin goals, we need to define:++- a command handler (`importLensCommand`),+- a code lens request handler (`lensProvider`).++These will be assembled in the `descriptor` function of the plugin, which contains all the information wrapped in the `PluginDescriptor` datatype mentioned above.++Using the convenience `defaultPluginDescriptor` function, we can bootstrap the plugin with the required parts:++```haskell+-- plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs++data Log++-- | The "main" function of a plugin.+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+ (defaultPluginDescriptor plId "A plugin for generating the minimal imports")+ { pluginCommands = [importLensCommand], -- The plugin provides a command handler+ pluginHandlers = mconcat -- The plugin provides request handlers+ [ mkPluginHandler SMethod_TextDocumentCodeLens provider+ ]+ }+```++We'll start with the command, since it's the simplest of the two.++### The command handler++In short, LSP commands work like this:++- The LSP server (HLS) initially sends a command descriptor to the client, in this case as part of a code lens.+- When the user clicks on the code lens, the client asks HLS to execute the command with the given descriptor. The server then handles and executes the command; this latter part is implemented by the `commandFunc` field of our `PluginCommand` value.++> **Note**: Check the [LSP spec](https://microsoft.github.io/language-server-protocol/specification) for a deeper understanding of how commands work.++The command handler will be called `importLensCommand` and have the `PluginCommand` type, a type defined in `Ide.Types` as:++```haskell ignore+-- hls-plugin-api/src/Ide/Types.hs++data PluginCommand ideState = forall a. (FromJSON a) =>+ PluginCommand { commandId :: CommandId+ , commandDesc :: T.Text+ , commandFunc :: CommandFunction ideState a+ }+```++Let's start by creating an unfinished command handler. We'll give it an ID and a description for now:++```haskell+-- | The command handler.+importLensCommand :: PluginCommand IdeState+importLensCommand =+ PluginCommand+ { commandId = importCommandId+ , commandDesc = "Explicit import command"+ , commandFunc = runImportCommand+ }++importCommandId :: CommandId+importCommandId = "ImportLensCommand"+```++```haskell ignore+-- | Not implemented yet.+runImportCommand = undefined+```++The most important (and still `undefined`) field is `commandFunc :: CommandFunction`, a type synonym from `LSP.Types`:++```haskell ignore+-- hls-plugin-api/src/Ide/Types.hs++type CommandFunction ideState a+ = ideState+ -> a+ -> LspM Config (Either ResponseError Value)+```++`CommandFunction` takes an `ideState` and a JSON-encodable argument. `LspM` is a monad transformer with access to IO, and having access to a language context environment `Config`. The action evaluates to an `Either` value. `Left` indicates failure with a `ResponseError`, `Right` indicates sucess with a `Value`.++Our handler will ignore the state argument and only use the `WorkspaceEdit` argument.++```haskell+-- | The type of the parameters accepted by our command+newtype ImportCommandParams = ImportCommandParams WorkspaceEdit+ deriving (Generic)+ deriving anyclass (FromJSON, ToJSON)++-- | The actual command handler+runImportCommand :: CommandFunction IdeState ImportCommandParams+runImportCommand _ _ (ImportCommandParams edit) = do+ -- This command simply triggers a workspace edit!+ _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+ return $ InR JL.Null+```++`runImportCommand` [sends a request](https://hackage.haskell.org/package/lsp/docs/Language-LSP-Server.html#v:sendRequest) to the client using the method `SWorkspaceApplyEdit` and the parameters `ApplyWorkspaceEditParams Nothing edit`, providing a response handler that does nothing. It then returns `Right Null`, which is an empty `Aeson.Value` wrapped in `Right`.++### The code lens provider++The code lens provider implements all the steps of the algorithm described earlier:++> 1. Request the type checking artifacts.+> 2. Extract the actual import lists from the type-checked AST.+> 3. Ask GHC to produce the minimal import lists for this AST.+> 4. For each import statement lacking an explicit list, determine its minimal import list and generate a code lens displaying this list along with a command to insert it.++The provider takes the usual `LspFuncs` and `IdeState` arguments, as well as a `CodeLensParams` value containing a file URI. It returns an IO action that produces either an error or a list of code lenses for that file.++```haskell+provider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens+provider state -- ghcide state, used to retrieve typechecking artifacts+ pId -- Plugin ID+ CodeLensParams{_textDocument = TextDocumentIdentifier{_uri}} = do+ -- VSCode uses URIs instead of file paths+ -- haskell-lsp provides conversion functions+ nfp <- getNormalizedFilePathE _uri+ -- Get the typechecking artifacts from the module+ tmr <- runActionE "importLens" state $ useE TypeCheck nfp+ -- We also need a GHC session with all the dependencies+ hsc <- runActionE "importLens" state $ useE GhcSessionDeps nfp+ -- Use the GHC API to extract the "minimal" imports+ (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr++ case mbMinImports of+ Just minImports -> do+ let minImportsMap =+ Map.fromList [ (realSrcLocToPosition loc, i)+ | L l i <- minImports+ , let RealSrcLoc loc _ = srcSpanStart (locA l)+ ]+ lenses <- forM imports $ \imp ->+ -- for every import, maybe generate a code lens+ liftIO (generateLens pId _uri minImportsMap imp)+ return $ InL (catMaybes lenses)+ _ ->+ return $ InL []+```++Note the simplicity of retrieving the type checking artifacts for the module, as well as a fully set up GHC session, via the `ghcide` rules.++The function `extractMinimalImports` extracts the import statements from the AST and generates the minimal import lists, implementing steps 2 and 3 of the algorithm.++The details of the GHC API are not relevant to this tutorial, but the code is terse and easy to read:++```haskell+extractMinimalImports+ :: HscEnvEq+ -> TcModuleResult+ -> IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn])+extractMinimalImports hsc TcModuleResult{..} = do+ -- Extract the original imports and the typechecking environment+ let tcEnv = tmrTypechecked+ (_, imports, _, _) = tmrRenamed+ ParsedModule{ pm_parsed_source = L loc _} = tmrParsed+ span = fromMaybe (error "expected real") $ realSpan loc++ -- GHC is secretly full of mutable state+ gblElts <- readIORef (tcg_used_gres tcEnv)++ let usage = findImportUsage imports gblElts+ (_, minimalImports) <-+ -- getMinimalImports computes the minimal explicit import lists+ initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage+ return (imports, minimalImports)+```++The function `generateLens` implements step 4 of the algorithm, producing a code lens for an import statement that lacks an import list. The code lens includes an `ImportCommandParams` value containing a workspace edit that rewrites the import statement, as our command provider expects.++```haskell+-- | Given an import declaration, generate a code lens unless it has an explicit import list+generateLens :: PluginId+ -> Uri+ -> Map Position (ImportDecl GhcRn)+ -> LImportDecl GhcRn+ -> IO (Maybe CodeLens)+generateLens pId uri minImports (L src imp)+ -- Explicit import list case+ | ImportDecl{ideclImportList = Just _} <- imp+ = return Nothing+ -- No explicit import list+ | RealSrcSpan l _ <- locA src+ , let position = realSrcLocToPosition $ realSrcSpanStart l+ , Just explicit <- Map.lookup position minImports+ , L _ mn <- ideclName imp+ -- (Almost) no one wants to see an explicit import list for Prelude+ , mn /= moduleName pRELUDE+ = do+ -- The title of the command is just the minimal explicit import decl+ let title = T.pack $ printWithoutUniques explicit+ -- The range of the code lens is the span of the original import decl+ _range :: Range = realSrcSpanToRange l+ -- The code lens has no extra data+ _xdata = Nothing+ -- An edit that replaces the whole declaration with the explicit one+ edit = WorkspaceEdit (Just editsMap) Nothing Nothing+ editsMap = Map.fromList [(uri, [importEdit])]+ importEdit = TextEdit _range title+ -- The command argument is simply the edit+ _arguments = Just [toJSON $ ImportCommandParams edit]+ _data_ = Nothing+ -- Create the command+ _command = Just $ mkLspCommand pId importCommandId title _arguments+ -- Create and return the code lens+ return $ Just CodeLens{..}+ | otherwise+ = return Nothing+```++## Wrapping up++There's only one Haskell code change left to do at this point: "link" the plugin in the `HlsPlugins` HLS module.++Integrating the plugin into HLS itself requires changes to several configuration files.++A good approach is to search for the ID of an existing plugin (e.g., `hls-class-plugin`):++- `./haskell-language-server.cabal`: Add a conditional block with the plugin package dependency.+- `./.github/workflows/test.yml`: Add a block to run the plugin's test suite.+- `./.github/workflows/hackage.yml`: Add the plugin to the component list for releasing the plugin package to Hackage.+- `./*.nix`: Add the plugin to Nix builds.++This plugin tutorial re-implements parts of the [`hls-explicit-imports-plugin`] which is part of HLS.+The plugin code additionally contains advanced concepts, such as `Rules`.++I hope this has given you a taste of how easy and joyful it is to write plugins for HLS. If you are looking for contribution ideas, here are some good ones listed in the HLS [issue tracker](https://github.com/haskell/haskell-language-server/issues).++<details>+ <summary>Placeholder Main, unused</summary>++```haskell+main :: IO ()+main = putStrLn "Just here to silence the error!"+```+</details>
exe/Wrapper.hs view
@@ -38,7 +38,8 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T-import Development.IDE.LSP.LanguageServer (runLanguageServer)+import Development.IDE.LSP.LanguageServer (Setup (..),+ runLanguageServer) import qualified Development.IDE.Main as Main import Ide.Logger (Doc, Pretty (pretty), Recorder, WithPriority,@@ -300,7 +301,12 @@ [ exitHandler exit ] let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO- pure (doInitialize, asyncHandlers, interpretHandler)+ pure MkSetup+ { doInitialize+ , staticHandlers = asyncHandlers+ , interpretHandler+ , onExit = [exit]+ } runLanguageServer (cmapWithPrio pretty recorder) (Main.argsLspOptions defaultArguments)
+ ghcide-test/data/references/Fields.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE RecordWildCards #-}+module Fields where++data Foo = MkFoo+ {+ barr :: String,+ bazz :: String+ }++fooUse0 :: Foo -> String+fooUse0 MkFoo{barr} = "5"++fooUse1 :: Foo -> String+fooUse1 MkFoo{..} = "6"++fooUse2 :: String -> String -> Foo+fooUse2 bar baz =+ MkFoo{..}
ghcide-test/data/references/Main.hs view
@@ -1,7 +1,7 @@ module Main where import References-+import Fields main :: IO () main = return () @@ -12,3 +12,6 @@ acc :: Account acc = Savings++fooUse3 :: String -> String -> Foo+fooUse3 bar baz = MkFoo{barr = bar, bazz = baz}
ghcide-test/data/references/hie.yaml view
@@ -1,1 +1,1 @@-cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}}+cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References", "Fields"]}}
ghcide-test/exe/CodeLensTests.hs view
@@ -10,7 +10,6 @@ import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T-import Data.Tuple.Extra import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types hiding@@ -28,7 +27,26 @@ [ addSigLensesTests ] +data TestSpec =+ TestSpec+ { mName :: Maybe TestName -- ^ Optional Test Name+ , input :: T.Text -- ^ Input+ , expected :: Maybe T.Text -- ^ Expected Type Sig+ } +mkT :: T.Text -> T.Text -> TestSpec+mkT i e = TestSpec Nothing i (Just e)+mkT' :: TestName -> T.Text -> T.Text -> TestSpec+mkT' name i e = TestSpec (Just name) i (Just e)++noExpected :: TestSpec -> TestSpec+noExpected t = t { expected = Nothing }++mkTestName :: TestSpec -> String+mkTestName t = case mName t of+ Nothing -> T.unpack $ T.replace "\n" "\\n" (input t)+ Just name -> name+ addSigLensesTests :: TestTree addSigLensesTests = let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"@@ -41,14 +59,14 @@ , "data T1 a where" , " MkT1 :: (Show b) => a -> b -> T1 a" ]- before enableGHCWarnings exported (def, _) others =- T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others- after' enableGHCWarnings exported (def, sig) others =- T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others+ before enableGHCWarnings exported spec others =+ T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, input spec] <> others+ after' enableGHCWarnings exported spec others =+ T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure (expected spec) <> [input spec] <> others createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]- sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do- let originalCode = before enableGHCWarnings exported def others- let expectedCode = after' enableGHCWarnings exported def others+ sigSession testName enableGHCWarnings waitForDiags mode exported spec others = testWithDummyPluginEmpty testName $ do+ let originalCode = before enableGHCWarnings exported spec others+ let expectedCode = after' enableGHCWarnings exported spec others setConfigSection "haskell" (createConfig mode) doc <- createDoc "Sigs.hs" "haskell" originalCode -- Because the diagnostics mode is really relying only on diagnostics now@@ -58,7 +76,7 @@ then void waitForDiagnostics else waitForProgressDone codeLenses <- getAndResolveCodeLenses doc- if not $ null $ snd def+ if isJust $ expected spec then do liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses executeCommand $ fromJust $ head codeLenses ^. L.command@@ -66,43 +84,46 @@ liftIO $ expectedCode @=? modifiedCode else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses cases =- [ ("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")- , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")- , ("head = 233", "head :: Integer")- , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, String)")- , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")- , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing")- , ("typeOperatorTest = Refl", "typeOperatorTest :: forall {k} {a :: k}. a :~: a")- , ("notInScopeTest = mkCharType"- , if ghcVersion < GHC910+ [ mkT "abc = True" "abc :: Bool"+ , mkT "foo a b = a + b" "foo :: Num a => a -> a -> a"+ , mkT "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"+ , mkT "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"+ , mkT "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"+ , mkT "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"+ , mkT "pattern Some a = Just a" "pattern Some :: a -> Maybe a"+ , mkT "pattern Some a <- Just a" "pattern Some :: a -> Maybe a"+ , mkT "pattern Some a <- Just a\n where Some a = Just a" "pattern Some :: a -> Maybe a"+ , mkT "pattern Some a <- Just !a\n where Some !a = Just a" "pattern Some :: a -> Maybe a"+ , mkT "pattern Point{x, y} = (x, y)" "pattern Point :: a -> b -> (a, b)"+ , mkT "pattern Point{x, y} <- (x, y)" "pattern Point :: a -> b -> (a, b)"+ , mkT "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" "pattern Point :: a -> b -> (a, b)"+ , mkT "pattern MkT1' b = MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+ , mkT "pattern MkT1' b <- MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+ , mkT "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"+ , mkT "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a"+ , mkT "head = 233" "head :: Integer"+ , mkT "rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")" "rank2Test :: (forall a. a -> a) -> (Int, String)"+ , mkT "symbolKindTest = Proxy @\"qwq\"" "symbolKindTest :: Proxy \"qwq\""+ , mkT "promotedKindTest = Proxy @Nothing" (if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing")+ , mkT "typeOperatorTest = Refl" "typeOperatorTest :: forall {k} {a :: k}. a :~: a"+ , mkT "notInScopeTest = mkCharType"+ (if ghcVersion < GHC910 then "notInScopeTest :: String -> Data.Data.DataType" else "notInScopeTest :: String -> GHC.Internal.Data.Data.DataType" )- , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool")++ , mkT' "aVeryLongSignature"+ "aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n"+ "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool" ] in testGroup "add signature"- [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases]- , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)+ [ testGroup "signatures are correct" [sigSession (mkTestName spec) False False "always" "" spec [] | spec <- cases]+ , sigSession "exported mode works" False False "exported" "xyz" (mkT "xyz = True" "xyz :: Bool") (input <$> take 3 cases) , testGroup "diagnostics mode works"- [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []- , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) []+ [ sigSession "with GHC warnings" True True "diagnostics" "" (head cases) []+ , sigSession "without GHC warnings" False False "diagnostics" "" (noExpected $ head cases) [] ] , testWithDummyPluginEmpty "keep stale lens" $ do let content = T.unlines
ghcide-test/exe/CompletionTests.hs view
@@ -33,7 +33,6 @@ import Test.Tasty import Test.Tasty.HUnit - tests :: TestTree tests = testGroup "completion"@@ -61,6 +60,7 @@ completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do docId <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics+ compls <- getAndResolveCompletions docId pos let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] let emptyToMaybe x = if T.null x then Nothing else Just x@@ -211,7 +211,38 @@ compls <- getCompletions doc (Position 0 15) liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]- pure ()+ pure (),+ completionTest+ "polymorphic record dot completion"+ [ "{-# LANGUAGE OverloadedRecordDot #-}"+ , "module A () where"+ , "data Record = Record"+ , " { field1 :: Int"+ , " , field2 :: Int"+ , " }"+ , -- Without the following, this file doesn't trigger any diagnostics, so completionTest waits forever+ "triggerDiag :: UnknownType"+ , "foo record = record.f"+ ]+ (Position 7 21)+ [("field1", CompletionItemKind_Function, "field1", True, False, Nothing)+ ,("field2", CompletionItemKind_Function, "field2", True, False, Nothing)+ ],+ completionTest+ "qualified polymorphic record dot completion"+ [ "{-# LANGUAGE OverloadedRecordDot #-}"+ , "module A () where"+ , "data Record = Record"+ , " { field1 :: Int"+ , " , field2 :: Int"+ , " }"+ , "someValue = undefined"+ , "foo = A.someValue.f"+ ]+ (Position 7 19)+ [("field1", CompletionItemKind_Function, "field1", True, False, Nothing)+ ,("field2", CompletionItemKind_Function, "field2", True, False, Nothing)+ ] ] nonLocalCompletionTests :: [TestTree]@@ -276,8 +307,7 @@ where brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason" brokenForWinOldGhc =- knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC94] "Windows (GHC == 9.4) has strange things in scope for some reason"- . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC96] "Windows (GHC == 9.6) has strange things in scope for some reason"+ knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC96] "Windows (GHC == 9.6) has strange things in scope for some reason" . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC98] "Windows (GHC == 9.8) has strange things in scope for some reason" otherCompletionTests :: [TestTree]@@ -350,10 +380,11 @@ , _label == "fromList" ] liftIO $ take 3 (sort compls') @?=- map ("Defined in "<>) (- [ "'Data.List.NonEmpty"+ map ("Defined in "<>) [+ "'Data.List.NonEmpty" , "'GHC.Exts"- ] ++ (["'GHC.IsList" | ghcVersion >= GHC94]))+ , "'GHC.IsList"+ ] , testSessionEmptyWithCradle "Map" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, containers, A]}}" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines
ghcide-test/exe/CradleTests.hs view
@@ -29,6 +29,7 @@ import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir)+import Test.Hls.FileSystem import Test.Hls.Util (EnvSpec (..), OS (..), ignoreInEnv) import Test.Tasty@@ -53,7 +54,7 @@ ] where direct dir = do- liftIO $ writeFileUTF8 (dir </> "hie.yaml")+ liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml") "cradle: {direct: {arguments: []}}" test dir implicit dir = test dir@@ -73,7 +74,7 @@ -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir </> "hie.yaml"- liftIO $ writeFile hiePath hieContents+ liftIO $ atomicFileWriteString hiePath hieContents let aPath = dir </> "A.hs" doc <- createDoc aPath "haskell" "main = return ()" WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc@@ -81,7 +82,7 @@ -- Fix the cradle and typecheck again let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"- liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle+ liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ] @@ -117,7 +118,11 @@ multiTests :: FilePath -> [TestTree] multiTests dir =- [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir]+ [ simpleMultiTest dir+ , simpleMultiTest2 dir+ , simpleMultiTest3 dir+ , simpleMultiDefTest dir+ ] multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name@@ -210,7 +215,7 @@ "session-deps-are-picked-up" $ \dir -> do liftIO $- writeFileUTF8+ atomicFileWriteStringUTF8 (dir </> "hie.yaml") "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error.@@ -219,7 +224,7 @@ -- Update hie.yaml to enable OverloadedStrings. liftIO $- writeFileUTF8+ atomicFileWriteStringUTF8 (dir </> "hie.yaml") "cradle: {direct: {arguments: [-XOverloadedStrings]}}" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
ghcide-test/exe/DependentFileTest.hs view
@@ -15,6 +15,7 @@ mkRange) import Language.LSP.Test import Test.Hls+import Test.Hls.FileSystem tests :: TestTree@@ -31,7 +32,7 @@ -- If the file contains B then no type error -- otherwise type error let depFilePath = "dep-file.txt"- liftIO $ writeFile depFilePath "A"+ liftIO $ atomicFileWriteString depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" , "module Foo where"@@ -48,7 +49,7 @@ expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])] -- Now modify the dependent file- liftIO $ writeFile depFilePath "B"+ liftIO $ atomicFileWriteString depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ]
ghcide-test/exe/DiagnosticTests.hs view
@@ -39,7 +39,7 @@ import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), runSessionWithTestConfig, waitForProgressBegin)-import Test.Hls.FileSystem (directCradle, file, text)+import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit @@ -244,9 +244,7 @@ _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])]- , testWithDummyPlugin "bidirectional module dependency with hs-boot"- (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]])- $ do+ , testWithDummyPluginEmpty "bidirectional module dependency with hs-boot" $ do let contentA = T.unlines [ "module ModuleA where" , "import {-# SOURCE #-} ModuleB"@@ -343,19 +341,9 @@ expectDiagnostics [ ( "Main.hs" , [(DiagnosticSeverity_Error, (6, 9),- if ghcVersion >= GHC96 then- "Variable not in scope: ThisList.map"- else if ghcVersion >= GHC94 then- "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130- else- "Not in scope: \8216ThisList.map\8217", Just "GHC-88464")+ "Variable not in scope: ThisList.map", Just "GHC-88464") ,(DiagnosticSeverity_Error, (7, 9),- if ghcVersion >= GHC96 then- "Variable not in scope: BaseList.x"- else if ghcVersion >= GHC94 then- "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130- else- "Not in scope: \8216BaseList.x\8217", Just "GHC-88464")+ "Variable not in scope: BaseList.x", Just "GHC-88464") ] ) ]@@ -373,7 +361,7 @@ -- where appropriate. The warning should use an unqualified name 'Ord', not -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to -- test this is fairly arbitrary.- , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a", Just "GHC-30606")+ , [(DiagnosticSeverity_Warning, (2, 7), "Redundant constraint: Ord a", Just "GHC-30606") ] ) ]@@ -393,7 +381,7 @@ let (drive, suffix) = splitDrive pathB in filePathToUri (joinDrive (lower drive) suffix) liftIO $ createDirectoryIfMissing True (takeDirectory pathB)- liftIO $ writeFileUTF8 pathB $ T.unpack bContent+ liftIO $ atomicFileWriteStringUTF8 pathB $ T.unpack bContent uriA <- getDocUri "A/A.hs" Just pathA <- pure $ uriToFilePath uriA uriA <- pure $
ghcide-test/exe/FindDefinitionAndHoverTests.hs view
@@ -187,7 +187,8 @@ holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]- reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], if ghcVersion >= GHC94 && ghcVersion < GHC910 then mkL bar 3 5 3 8 else mkL bar 3 0 3 14]+ reexported = Position 55 14+ reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], if ghcVersion < GHC910 || not isWindows then mkL bar 3 5 3 8 else mkL bar 3 0 3 14] thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]]@@ -237,9 +238,9 @@ , testM yes yes imported importedSig "Imported symbol" , if isWindows then -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997- testM no yes reexported reexportedSig "Imported symbol (reexported)"+ testM no yes reexported reexportedSig "Imported symbol reexported" else- testM yes yes reexported reexportedSig "Imported symbol (reexported)"+ testM yes yes reexported reexportedSig "Imported symbol reexported" , test no yes thLocL57 thLoc "TH Splice Hover" , test yes yes import310 pkgTxt "show package name and its version" ]
ghcide-test/exe/GarbageCollectionTests.hs view
@@ -12,6 +12,7 @@ SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath+import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit import Text.Printf (printf)@@ -20,14 +21,14 @@ tests = testGroup "garbage collection" [ testGroup "dirty keys" [ testWithDummyPluginEmpty' "are collected" $ \dir -> do- liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+ liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}" doc <- generateGarbage "A" dir closeDoc doc garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do- liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+ liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir keys0 <- getStoredKeys closeDoc docA@@ -37,7 +38,7 @@ liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do- liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"+ liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" docA <- generateGarbage "A" dir _docB <- generateGarbage "B" dir @@ -58,7 +59,7 @@ liftIO $ regeneratedKeys @?= mempty , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do- liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+ liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir closeDoc docA garbage <- waitForGC@@ -83,7 +84,7 @@ let fp = modName <> ".hs" body = printf "module %s where" modName doc <- createDoc fp "haskell" (T.pack body)- liftIO $ writeFile (dir </> fp) body+ liftIO $ atomicFileWriteString (dir </> fp) body builds <- waitForTypecheck doc liftIO $ assertBool "something is wrong with this test" builds return doc
ghcide-test/exe/IfaceTests.hs view
@@ -18,6 +18,7 @@ import System.Directory import System.FilePath import System.IO.Extra hiding (withTempDir)+import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit @@ -45,7 +46,7 @@ cdoc <- createDoc cPath "haskell" cSource -- Change [TH]a from () to Bool- liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])+ liftIO $ atomicFileWriteStringUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) -- Check that the change propagates to C changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource]
ghcide-test/exe/PluginSimpleTests.hs view
@@ -9,6 +9,7 @@ SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath+import Test.Hls.FileSystem import Test.Tasty tests :: TestTree@@ -36,7 +37,7 @@ -- required by plugin-1.0.0). See the build log above for details. testWithExtraFiles "simple plugin" "plugin-knownnat" $ \dir -> do _ <- openDoc (dir </> "KnownNat.hs") "haskell"- liftIO $ writeFile (dir</>"hie.yaml")+ liftIO $ atomicFileWriteString (dir</>"hie.yaml") "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" expectDiagnostics
ghcide-test/exe/ReferenceTests.hs view
@@ -115,7 +115,7 @@ ] , testGroup "can get references to non FOIs"- [ referenceTest "can get references to symbol defined in a module we import"+ [ referenceTest "references to symbol defined in a module we import" ("References.hs", 22, 4) YesIncludeDeclaration [ ("References.hs", 22, 4)@@ -123,7 +123,7 @@ , ("OtherModule.hs", 4, 0) ] - , referenceTest "can get references in modules that import us to symbols we define"+ , referenceTest "references in modules that import us to symbols we define" ("OtherModule.hs", 4, 0) YesIncludeDeclaration [ ("References.hs", 22, 4)@@ -131,7 +131,7 @@ , ("OtherModule.hs", 4, 0) ] - , referenceTest "can get references to symbol defined in a module we import transitively"+ , referenceTest "references to symbol defined in a module we import transitively" ("References.hs", 24, 4) YesIncludeDeclaration [ ("References.hs", 24, 4)@@ -139,7 +139,7 @@ , ("OtherOtherModule.hs", 2, 0) ] - , referenceTest "can get references in modules that import us transitively to symbols we define"+ , referenceTest "references in modules that transitively use symbols we define" ("OtherOtherModule.hs", 2, 0) YesIncludeDeclaration [ ("References.hs", 24, 4)@@ -147,13 +147,35 @@ , ("OtherOtherModule.hs", 2, 0) ] - , referenceTest "can get type references to other modules"+ , referenceTest "type references to other modules" ("Main.hs", 12, 10) YesIncludeDeclaration [ ("Main.hs", 12, 7) , ("Main.hs", 13, 0) , ("References.hs", 12, 5) , ("References.hs", 16, 0)+ ]+ ]+ -- Fields.hs does not depend on Main.hs+ -- so we can only find references in Fields.hs+ , testGroup "references to record fields"+ [ referenceTest "references record fields in the same file"+ ("Fields.hs", 5, 4)+ YesIncludeDeclaration+ [ ("Fields.hs", 5, 4)+ , ("Fields.hs", 10, 14)+ , ("Fields.hs", 13, 14)+ ]++ -- Main.hs depends on Fields.hs, so we can find references+ -- from Main.hs to Fields.hs+ , referenceTest "references record fields cross modules"+ ("Main.hs", 16, 24)+ YesIncludeDeclaration+ [ ("Fields.hs", 5, 4)+ , ("Fields.hs", 10, 14)+ , ("Fields.hs", 13, 14)+ , ("Main.hs", 16, 24) ] ] ]
ghcide-test/exe/UnitTests.hs view
@@ -31,6 +31,7 @@ import Test.Hls (IdeState, def, runSessionWithServerInTmpDir, waitForProgressDone)+import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit@@ -104,9 +105,9 @@ findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do performGC- writeFile f ""+ atomicFileWriteString f "" threadDelay delay_us- writeFile f' ""+ atomicFileWriteString f' "" t <- getModTime f t' <- getModTime f' if t /= t' then return delay_us else findResolution_us (delay_us * 10)
ghcide-test/exe/WatchedFileTests.hs view
@@ -29,7 +29,7 @@ tests = testGroup "watched files" [ testGroup "Subscriptions" [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do- liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"+ liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" setIgnoringRegistrationRequests False watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics@@ -40,7 +40,7 @@ , testWithDummyPluginEmpty' "non workspace file" $ \sessionDir -> do tmpDir <- liftIO getTemporaryDirectory let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"- liftIO $ writeFile (sessionDir </> "hie.yaml") yaml+ liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") yaml _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" setIgnoringRegistrationRequests False watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics@@ -53,8 +53,8 @@ , testGroup "Changes" [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do- liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"- liftIO $ writeFile (sessionDir </> "B.hs") $ unlines+ liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"+ liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines ["module B where" ,"b :: Bool" ,"b = False"]@@ -66,7 +66,7 @@ ] expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])] -- modify B off editor- liftIO $ writeFile (sessionDir </> "B.hs") $ unlines+ liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines ["module B where" ,"b :: Int" ,"b = 0"]@@ -80,7 +80,7 @@ let cabalFile = "reload.cabal" cabalContent <- liftIO $ T.readFile cabalFile let fix = T.replace "build-depends: base" "build-depends: base, split"- liftIO $ T.writeFile cabalFile (fix cabalContent)+ liftIO $ atomicFileWriteText cabalFile (fix cabalContent) sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [ FileEvent (filePathToUri $ sessionDir </> cabalFile) FileChangeType_Changed ] expectDiagnostics [(hsFile, [])]
haskell-language-server.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.4 category: Development name: haskell-language-server-version: 2.11.0.0+version: 2.12.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -14,7 +14,7 @@ license: Apache-2.0 license-file: LICENSE build-type: Simple-tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8+tested-with: GHC == {9.12.2, 9.10.2, 9.8.4, 9.6.7} extra-source-files: README.md ChangeLog.md@@ -136,8 +136,8 @@ build-depends: , directory , filepath- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp-types , mtl@@ -157,8 +157,8 @@ , filepath , haskell-language-server:hls-cabal-plugin , haskell-language-server:hls-cabal-fmt-plugin- , hls-plugin-api == 2.11.0.0- , hls-test-utils == 2.11.0.0+ , hls-plugin-api == 2.12.0.0+ , hls-test-utils == 2.12.0.0 if flag(isolateCabalfmtTests) build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.12@@ -193,8 +193,8 @@ build-depends: , directory , filepath- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp-types , text , mtl@@ -213,8 +213,8 @@ , filepath , haskell-language-server:hls-cabal-plugin , haskell-language-server:hls-cabal-gild-plugin- , hls-plugin-api == 2.11.0.0- , hls-test-utils == 2.11.0.0+ , hls-plugin-api == 2.12.0.0+ , hls-test-utils == 2.12.0.0 if flag(isolateCabalGildTests) -- https://github.com/tfausak/cabal-gild/issues/89@@ -254,8 +254,13 @@ Ide.Plugin.Cabal.Completion.Types Ide.Plugin.Cabal.Definition Ide.Plugin.Cabal.FieldSuggest+ Ide.Plugin.Cabal.Files+ Ide.Plugin.Cabal.OfInterest Ide.Plugin.Cabal.LicenseSuggest- Ide.Plugin.Cabal.CabalAdd+ Ide.Plugin.Cabal.Rules+ Ide.Plugin.Cabal.CabalAdd.Command+ Ide.Plugin.Cabal.CabalAdd.CodeAction+ Ide.Plugin.Cabal.CabalAdd.Types Ide.Plugin.Cabal.Orphans Ide.Plugin.Cabal.Outline Ide.Plugin.Cabal.Parse@@ -269,21 +274,21 @@ , directory , filepath , extra >=1.7.4- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hashable- , hls-plugin-api == 2.11.0.0- , hls-graph == 2.11.0.0+ , hls-plugin-api == 2.12.0.0+ , hls-graph == 2.12.0.0 , lens , lsp ^>=2.7 , lsp-types ^>=2.3+ , mtl , regex-tdfa ^>=1.3.1 , text , text-rope , transformers , unordered-containers >=0.2.10.0 , containers- , cabal-add- , process+ , cabal-add ^>=0.2 , aeson , Cabal , pretty@@ -311,11 +316,11 @@ , filepath , ghcide , haskell-language-server:hls-cabal-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens+ , lsp , lsp-types , text- , hls-plugin-api ----------------------------- -- class plugin@@ -349,9 +354,9 @@ , extra , ghc , ghc-exactprint >= 1.5 && < 1.13.0.0- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hls-graph- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , mtl@@ -372,7 +377,7 @@ build-depends: , filepath , haskell-language-server:hls-class-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -406,9 +411,10 @@ , aeson , containers , extra- , ghcide == 2.11.0.0- , hiedb ^>= 0.6.0.2- , hls-plugin-api == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0+ , hiedb ^>= 0.7.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp >=2.7 , sqlite-simple@@ -429,7 +435,7 @@ , extra , filepath , haskell-language-server:hls-call-hierarchy-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp , lsp-test@@ -473,15 +479,15 @@ , bytestring , containers , deepseq- , Diff ^>=0.5+ , Diff ^>=0.5 || ^>=1.0.0 , dlist , extra , filepath , ghc , ghc-boot-th- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hls-graph- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , lsp-types@@ -512,7 +518,7 @@ , filepath , haskell-language-server:hls-eval-plugin , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -542,9 +548,9 @@ , containers , deepseq , ghc- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hls-graph- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , mtl@@ -565,7 +571,7 @@ , extra , filepath , haskell-language-server:hls-explicit-imports-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -592,11 +598,11 @@ hs-source-dirs: plugins/hls-rename-plugin/src build-depends: , containers- , ghcide == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0 , hashable- , hiedb ^>= 0.6.0.2- , hie-compat- , hls-plugin-api == 2.11.0.0+ , hiedb ^>= 0.7.0.0+ , hls-plugin-api == 2.12.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp-types@@ -621,7 +627,7 @@ , filepath , hls-plugin-api , haskell-language-server:hls-rename-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -652,9 +658,9 @@ , containers , extra , ghc- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hashable- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp@@ -683,7 +689,7 @@ , filepath , hls-plugin-api , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin}- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , text -----------------------------@@ -703,14 +709,14 @@ manual: True common hlint- if flag(hlint) && ((impl(ghc < 9.10) || impl(ghc > 9.11)) || flag(ignore-plugins-ghc-bounds))+ if flag(hlint) build-depends: haskell-language-server:hls-hlint-plugin cpp-options: -Dhls_hlint library hls-hlint-plugin import: defaults, pedantic, warnings -- https://github.com/ndmitchell/hlint/pull/1594- if !(flag(hlint)) || ((impl(ghc >= 9.10) && impl(ghc < 9.11)) && !flag(ignore-plugins-ghc-bounds))+ if !flag(hlint) buildable: False exposed-modules: Ide.Plugin.Hlint hs-source-dirs: plugins/hls-hlint-plugin/src@@ -720,10 +726,10 @@ , containers , deepseq , filepath- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hashable , hlint >= 3.5 && < 3.11- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , mtl , refact@@ -735,10 +741,14 @@ , transformers , unordered-containers , ghc-lib-parser-ex- , apply-refact- -- , lsp-types + -- apply-refact doesn't work on 9.10, or even have a buildable+ -- configuration+ if impl(ghc >= 9.11) || impl(ghc < 9.10)+ cpp-options: -DAPPLY_REFACT+ build-depends: apply-refact+ if flag(ghc-lib) cpp-options: -DGHC_LIB build-depends:@@ -753,7 +763,7 @@ test-suite hls-hlint-plugin-tests import: defaults, pedantic, test-defaults, warnings- if !flag(hlint) || ((impl(ghc >= 9.10) && impl(ghc < 9.11)) && !flag(ignore-plugins-ghc-bounds))+ if !flag(hlint) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-hlint-plugin/test@@ -761,13 +771,14 @@ -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/24648 if os(darwin) ghc-options: -optl-Wl,-ld_classic+ build-depends: aeson , containers , filepath , haskell-language-server:hls-hlint-plugin , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -795,13 +806,12 @@ build-depends: , deepseq , hashable- , hie-compat , hls-plugin-api , ghcide , lsp-types , text , unordered-containers- , stan >= 0.1.2.0+ , stan >= 0.2.1.0 , trial , directory @@ -822,7 +832,7 @@ , filepath , haskell-language-server:hls-stan-plugin , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -830,6 +840,59 @@ OverloadedStrings -----------------------------+-- signature help plugin+-----------------------------++flag signatureHelp+ description: Enable signature help plugin+ default: True+ manual: True++common signatureHelp+ if flag(signatureHelp)+ build-depends: haskell-language-server:hls-signature-help-plugin+ cpp-options: -Dhls_signatureHelp++library hls-signature-help-plugin+ import: defaults, pedantic, warnings+ if !flag(signatureHelp)+ buildable: False+ exposed-modules: Ide.Plugin.SignatureHelp+ hs-source-dirs: plugins/hls-signature-help-plugin/src+ default-extensions:+ DerivingStrategies+ LambdaCase+ OverloadedStrings+ build-depends:+ , containers+ , ghc+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0+ , lsp-types+ , text+ , transformers+++test-suite hls-signature-help-plugin-tests+ import: defaults, pedantic, test-defaults, warnings+ if !flag(signatureHelp)+ buildable: False+ type: exitcode-stdio-1.0+ hs-source-dirs: plugins/hls-signature-help-plugin/test+ main-is: Main.hs+ build-depends:+ , ghcide+ , haskell-language-server:hls-signature-help-plugin+ , hls-test-utils == 2.12.0.0+ , lens+ , lsp-types+ , string-interpolate+ , text+ default-extensions:+ DerivingStrategies+ OverloadedStrings++----------------------------- -- module name plugin ----------------------------- @@ -853,8 +916,8 @@ , aeson , containers , filepath- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp , text , text-rope@@ -871,7 +934,7 @@ build-depends: , filepath , haskell-language-server:hls-module-name-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 ----------------------------- -- pragmas plugin@@ -897,8 +960,8 @@ , aeson , extra , fuzzy- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lens-aeson , lsp@@ -917,7 +980,7 @@ , aeson , filepath , haskell-language-server:hls-pragmas-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-types , text@@ -950,8 +1013,8 @@ , extra , foldl , ghc- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp@@ -974,7 +1037,7 @@ build-depends: , filepath , haskell-language-server:hls-splice-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , text -----------------------------@@ -1001,10 +1064,10 @@ build-depends: , containers , extra- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , ghc-boot-th , hls-graph- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp ^>=2.7 , mtl@@ -1029,7 +1092,7 @@ build-depends: , filepath , haskell-language-server:hls-alternate-number-format-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , regex-tdfa , tasty-quickcheck , text@@ -1061,8 +1124,9 @@ hs-source-dirs: plugins/hls-qualify-imported-names-plugin/src build-depends: , containers- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , text@@ -1084,7 +1148,7 @@ , text , filepath , haskell-language-server:hls-qualify-imported-names-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 ----------------------------- -- code range plugin@@ -1114,9 +1178,10 @@ , containers , deepseq , extra- , ghcide == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0 , hashable- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , mtl@@ -1138,7 +1203,7 @@ , bytestring , filepath , haskell-language-server:hls-code-range-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp , lsp-test@@ -1166,14 +1231,16 @@ exposed-modules: Ide.Plugin.ChangeTypeSignature hs-source-dirs: plugins/hls-change-type-signature-plugin/src build-depends:- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0+ , lens , lsp-types , regex-tdfa , syb , text , transformers , containers+ , ghc default-extensions: DataKinds ExplicitNamespaces@@ -1191,7 +1258,8 @@ build-depends: , filepath , haskell-language-server:hls-change-type-signature-plugin- , hls-test-utils == 2.11.0.0+ , hls-plugin-api+ , hls-test-utils == 2.12.0.0 , regex-tdfa , text default-extensions:@@ -1224,9 +1292,9 @@ , containers , extra , ghc- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , ghc-exactprint- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp >=2.7@@ -1246,7 +1314,7 @@ build-depends: , filepath , haskell-language-server:hls-gadt-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , text -----------------------------@@ -1273,9 +1341,9 @@ , containers , deepseq , extra- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , hashable- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , lsp >=2.7 , text @@ -1291,7 +1359,7 @@ build-depends: , filepath , haskell-language-server:hls-explicit-fixity-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , text -----------------------------@@ -1314,8 +1382,9 @@ buildable: False exposed-modules: Ide.Plugin.ExplicitFields build-depends:- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp , lens , hls-graph@@ -1341,7 +1410,7 @@ , text , ghcide , haskell-language-server:hls-explicit-record-fields-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 ----------------------------- -- overloaded record dot plugin@@ -1387,7 +1456,7 @@ , filepath , text , haskell-language-server:hls-overloaded-record-dot-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 -----------------------------@@ -1413,8 +1482,8 @@ hs-source-dirs: plugins/hls-floskell-plugin/src build-depends: , floskell ^>=0.11.0- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp-types ^>=2.3 , mtl , text@@ -1430,7 +1499,7 @@ build-depends: , filepath , haskell-language-server:hls-floskell-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 ----------------------------- -- fourmolu plugin@@ -1454,10 +1523,10 @@ hs-source-dirs: plugins/hls-fourmolu-plugin/src build-depends: , filepath- , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 || ^>=0.17 || ^>=0.18+ , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 || ^>=0.17 || ^>=0.18 || ^>=0.19 , ghc-boot-th- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp , mtl@@ -1483,7 +1552,7 @@ , filepath , haskell-language-server:hls-fourmolu-plugin , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lsp-test -----------------------------@@ -1510,8 +1579,8 @@ , extra , filepath , ghc-boot-th- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp , mtl , process-extras >= 0.7.1@@ -1537,7 +1606,7 @@ , filepath , haskell-language-server:hls-ormolu-plugin , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lsp-types , ormolu @@ -1566,8 +1635,8 @@ , directory , filepath , ghc-boot-th- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp-types , mtl , stylish-haskell >=0.12 && <0.16@@ -1584,7 +1653,7 @@ build-depends: , filepath , haskell-language-server:hls-stylish-haskell-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 ----------------------------- -- refactor plugin@@ -1636,8 +1705,8 @@ , bytestring , ghc-boot , regex-tdfa- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lsp , text , text-rope@@ -1675,7 +1744,7 @@ , filepath , ghcide:ghcide , haskell-language-server:hls-refactor-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-test , lsp-types@@ -1722,8 +1791,9 @@ , extra , text-rope , mtl >= 2.2- , ghcide == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghc+ , ghcide == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp >=2.6 , text@@ -1733,7 +1803,7 @@ , array , deepseq , dlist- , hls-graph == 2.11.0.0+ , hls-graph == 2.12.0.0 , template-haskell , data-default , stm@@ -1754,10 +1824,10 @@ , containers , data-default , filepath- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , haskell-language-server:hls-semantic-tokens-plugin- , hls-plugin-api == 2.11.0.0- , hls-test-utils == 2.11.0.0+ , hls-plugin-api == 2.12.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp , lsp-test@@ -1787,9 +1857,9 @@ hs-source-dirs: plugins/hls-notes-plugin/src build-depends: , array- , ghcide == 2.11.0.0- , hls-graph == 2.11.0.0- , hls-plugin-api == 2.11.0.0+ , ghcide == 2.12.0.0+ , hls-graph == 2.12.0.0+ , hls-plugin-api == 2.12.0.0 , lens , lsp >=2.7 , mtl >= 2.2@@ -1815,7 +1885,7 @@ build-depends: , filepath , haskell-language-server:hls-notes-plugin- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 default-extensions: OverloadedStrings ----------------------------@@ -1841,6 +1911,7 @@ , retrie , hlint , stan+ , signatureHelp , moduleName , pragmas , splice@@ -1875,10 +1946,10 @@ , extra , filepath , ghc- , ghcide == 2.11.0.0+ , ghcide == 2.12.0.0 , githash >=0.1.6.1 , hie-bios- , hls-plugin-api == 2.11.0.0+ , hls-plugin-api == 2.12.0.0 , optparse-applicative , optparse-simple , prettyprinter >= 1.7@@ -1981,7 +2052,7 @@ , ghcide:ghcide , hashable , hls-plugin-api- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , lens , lsp-test , lsp-types@@ -2025,7 +2096,7 @@ build-depends: , extra- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 , process hs-source-dirs: test/wrapper@@ -2118,7 +2189,7 @@ , text , text-rope , unordered-containers- , hls-test-utils == 2.11.0.0+ , hls-test-utils == 2.12.0.0 if impl(ghc <9.3) build-depends: ghc-typelits-knownnat@@ -2265,3 +2336,28 @@ OverloadedStrings RecordWildCards ViewPatterns++executable plugin-tutorial+ import: defaults+ -- The plugin tutorial is only compatible with 9.6 and 9.8.+ -- No particular reason, just to avoid excessive CPP.+ if (impl(ghc >= 9.6) && impl(ghc < 9.10))+ buildable: True+ else+ buildable: False+ ghc-options: -pgmL markdown-unlit+ main-is: docs/contributing/plugin-tutorial.lhs+ build-tool-depends: markdown-unlit:markdown-unlit+ build-depends:+ base,+ ghcide,+ hls-plugin-api,+ aeson,+ lsp,+ lsp-types,+ markdown-unlit,+ text,+ unordered-containers,+ containers,+ transformers,+ ghc,
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs view
@@ -2,65 +2,53 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where -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 as List-import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe-import Data.Proxy import qualified Data.Text () import qualified Data.Text as T-import qualified Data.Text.Encoding as Encoding-import Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE as D import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.Core.Shake (restartShakeSession)-import qualified Development.IDE.Core.Shake as Shake-import Development.IDE.Graph (Key,- alwaysRerun)+import Development.IDE.Graph (Key) import Development.IDE.LSP.HoverDefinition (foundHover) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import Development.IDE.Types.Shake (toKey)-import qualified Distribution.CabalSpecVersion as Cabal import qualified Distribution.Fields as Syntax import Distribution.Package (Dependency) import Distribution.PackageDescription (allBuildDepends, depPkgName, unPackageName) import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax-import GHC.Generics-import qualified Ide.Plugin.Cabal.CabalAdd as CabalAdd+import qualified Ide.Plugin.Cabal.CabalAdd.CodeAction as CabalAdd+import qualified Ide.Plugin.Cabal.CabalAdd.Command as CabalAdd import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields 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.Data as Data import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), ParseCabalFields (..), ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types import Ide.Plugin.Cabal.Definition (gotoDefinition)-import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest+import qualified Ide.Plugin.Cabal.Files as CabalAdd import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest+import qualified Ide.Plugin.Cabal.OfInterest as OfInterest import Ide.Plugin.Cabal.Orphans () import Ide.Plugin.Cabal.Outline-import qualified Ide.Plugin.Cabal.Parse as Parse+import qualified Ide.Plugin.Cabal.Rules as Rules import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL@@ -71,7 +59,8 @@ data Log = LogModificationTime NormalizedFilePath FileVersion- | LogShake Shake.Log+ | LogRule Rules.Log+ | LogOfInterest OfInterest.Log | LogDocOpened Uri | LogDocModified Uri | LogDocSaved Uri@@ -84,7 +73,8 @@ instance Pretty Log where pretty = \case- LogShake log' -> pretty log'+ LogRule log' -> pretty log'+ LogOfInterest log' -> pretty log' LogModificationTime nfp modTime -> "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) LogDocOpened uri ->@@ -105,28 +95,30 @@ LogCompletions logs -> pretty logs LogCabalAdd logs -> pretty logs --- | Some actions with cabal files originate from haskell files.--- This descriptor allows to hook into the diagnostics of haskell source files, and--- allows us to provide code actions and commands that interact with `.cabal` files.+{- | Some actions in cabal files can be triggered from haskell files.+This descriptor allows us to hook into the diagnostics of haskell source files and+allows us to provide code actions and commands that interact with `.cabal` files.+-} haskellInteractionDescriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState haskellInteractionDescriptor recorder plId = (defaultPluginDescriptor plId "Provides the cabal-add code action in haskell files") { pluginHandlers = mconcat- [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction cabalAddCodeAction+ [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ cabalAddDependencyCodeAction recorder+ , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ cabalAddModuleCodeAction recorder ]- , pluginCommands = [PluginCommand CabalAdd.cabalAddCommand "add a dependency to a cabal file" (CabalAdd.command cabalAddRecorder)]- , pluginRules = pure ()- , pluginNotificationHandlers = mempty+ , pluginCommands =+ [ PluginCommand CabalAdd.cabalAddDependencyCommandId "add a dependency to a cabal file" (CabalAdd.addDependencyCommand cabalAddRecorder)+ , PluginCommand CabalAdd.cabalAddModuleCommandId "add a module to a cabal file" (CabalAdd.addModuleCommand cabalAddRecorder)+ ] }- where- cabalAddRecorder = cmapWithPrio LogCabalAdd recorder-+ where+ cabalAddRecorder = cmapWithPrio LogCabalAdd recorder 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+ { pluginRules = Rules.cabalRules ruleRecorder plId , pluginHandlers = mconcat [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction@@ -143,32 +135,35 @@ whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $- addFileOfInterest recorder ide file Modified{firstOpen = True}+ OfInterest.addFileOfInterest ofInterestRecorder ide file Modified{firstOpen = True} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocModified _uri restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $- addFileOfInterest recorder ide file Modified{firstOpen = False}+ OfInterest.addFileOfInterest ofInterestRecorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri- restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $- addFileOfInterest recorder ide file OnDisk+ restartCabalShakeSessionPhysical (shakeExtras ide) vfs file "(saved)" $+ OfInterest.addFileOfInterest ofInterestRecorder ide file OnDisk , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocClosed _uri restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $- deleteFileOfInterest recorder ide file+ OfInterest.deleteFileOfInterest ofInterestRecorder ide file ]- , pluginConfigDescriptor = defaultConfigDescriptor- { configHasDiagnostics = True- }+ , pluginConfigDescriptor =+ defaultConfigDescriptor+ { configHasDiagnostics = True+ } } where log' = logWith recorder+ ruleRecorder = cmapWithPrio LogRule recorder+ ofInterestRecorder = cmapWithPrio LogOfInterest recorder whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath'@@ -188,144 +183,36 @@ keys <- actionBetweenSession return (toKey GetModificationTime file:keys) --- ------------------------------------------------------------------- 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) $ \ParseCabalFields 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 $ Rope.toText sources- Nothing -> do- liftIO $ BS.readFile $ fromNormalizedFilePath file-- case Parse.readCabalFields file contents of- Left _ ->- pure ([], Nothing)- Right fields ->- pure ([], Just fields)-- define (cmapWithPrio LogShake recorder) $ \ParseCabalCommonSections file -> do- fields <- use_ ParseCabalFields file- let commonSections = Maybe.mapMaybe (\case- commonSection@(Syntax.Section (Syntax.Name _ "common") _ _) -> Just commonSection- _ -> Nothing)- fields- pure ([], Just commonSections)-- define (cmapWithPrio LogShake recorder) $ \ParseCabalFile 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 $ Rope.toText sources- Nothing -> do- liftIO $ BS.readFile $ fromNormalizedFilePath file-- -- Instead of fully reparsing the sources to get a 'GenericPackageDescription',- -- we would much rather re-use the already parsed results of 'ParseCabalFields'.- -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''- -- which allows us to resume the parsing pipeline with '[Field Position]'.- (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents- let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings- case pm of- Left (_cabalVersion, pErrorNE) -> do- let regexUnknownCabalBefore310 :: T.Text- -- We don't support the cabal version, this should not be an error, as the- -- user did not do anything wrong. Instead we cast it to a warning- regexUnknownCabalBefore310 = "Unsupported cabal-version [0-9]+.[0-9]*"- regexUnknownCabalVersion :: T.Text- regexUnknownCabalVersion = "Unsupported cabal format version in cabal-version field: [0-9]+.[0-9]+"- unsupportedCabalHelpText = unlines- [ "The used `cabal-version` is not fully supported by this `HLS` binary."- , "Either the `cabal-version` is unknown, or too new for this executable."- , "This means that some functionality might not work as expected."- , "If you face any issues, try downgrading to a supported `cabal-version` or upgrading `HLS` if possible."- , ""- , "Supported versions are: " <>- List.intercalate ", "- (fmap Cabal.showCabalSpecVersion Data.supportedCabalVersions)- ]- errorDiags =- NE.toList $- NE.map- ( \pe@(PError pos text) ->- if any (text =~)- [ regexUnknownCabalBefore310- , regexUnknownCabalVersion- ]- then Diagnostics.warningDiagnostic file (Syntax.PWarning Syntax.PWTOther pos $- unlines- [ text- , unsupportedCabalHelpText- ])- else Diagnostics.errorDiagnostic file pe- )- 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- Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile+-- | Just like 'restartCabalShakeSession', but records that the 'file' has been changed on disk.+-- So, any action that can only work with on-disk modifications may depend on the 'GetPhysicalModificationTime'+-- rule to get re-run if the file changes on disk.+restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO ()+restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do+ restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do+ keys <- actionBetweenSession+ return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) -- ---------------------------------------------------------------- -- Code Actions -- ---------------------------------------------------------------- licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction-licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = do+licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics = diags}) = do maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri) --- | CodeActions for correcting field names with typos in them.------ Provides CodeActions that fix typos in both stanzas and top-level field names.--- The suggestions are computed based on the completion context, where we "move" a fake cursor--- to the end of the field name and trigger cabal file completions. The completions are then--- suggested to the user.------ TODO: Relying on completions here often does not produce the desired results, we should--- use some sort of fuzzy matching in the future, see issue #4357.+{- | CodeActions for correcting field names with typos in them.++Provides CodeActions that fix typos in both stanzas and top-level field names.+The suggestions are computed based on the completion context, where we "move" a fake cursor+to the end of the field name and trigger cabal file completions. The completions are then+suggested to the user.++TODO: Relying on completions here often does not produce the desired results, we should+use some sort of fuzzy matching in the future, see issue #4357.+-} fieldSuggestCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction-fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do+fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = do mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri case (,) <$> mContents <*> uriToFilePath' uri of Nothing -> pure $ InL []@@ -340,47 +227,80 @@ let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags results <- forM fields (getSuggestion fileContents path cabalFields) pure $ InL $ map InR $ concat results- where- getSuggestion fileContents fp cabalFields (fieldName,Diagnostic{ _range=_range@(Range (Position lineNr col) _) }) = do- let -- Compute where we would anticipate the cursor to be.- fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName))- lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents- cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo- completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields- let completionTexts = fmap (^. JL.label) completions- pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range+ where+ getSuggestion fileContents fp cabalFields (fieldName, Diagnostic{_range = _range@(Range (Position lineNr col) _)}) = do+ let+ -- Compute where we would anticipate the cursor to be.+ fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName))+ lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents+ cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo+ completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields+ let completionTexts = fmap (^. JL.label) completions+ pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range -cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction-cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do- maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal.cabal-add" state getClientConfigAction- let suggestions = take maxCompls $ concatMap CabalAdd.hiddenPackageSuggestion diags+cabalAddDependencyCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+cabalAddDependencyCodeAction _ state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = do+ let suggestions = concatMap CabalAdd.hiddenPackageSuggestion diags case suggestions of [] -> pure $ InL []- _ ->- case uriToFilePath uri of+ _ -> do+ haskellFilePath <- uriToFilePathE uri+ mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath+ case mbCabalFile of Nothing -> pure $ InL []- Just haskellFilePath -> do- mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath- case mbCabalFile of+ Just cabalFilePath -> do+ verTxtDocId <-+ runActionE "cabalAdd.getVersionedTextDoc" state $+ lift $+ getVersionedTextDoc $+ TextDocumentIdentifier (filePathToUri cabalFilePath)+ mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath+ case mbGPD of Nothing -> pure $ InL []- Just cabalFilePath -> do- verTxtDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $- lift $ getVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath)- mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath- case mbGPD of- Nothing -> pure $ InL []- Just (gpd, _) -> do- actions <- liftIO $ CabalAdd.addDependencySuggestCodeAction plId verTxtDocId- suggestions- haskellFilePath cabalFilePath- gpd- pure $ InL $ fmap InR actions+ Just (gpd, _) -> do+ actions <-+ liftIO $+ CabalAdd.addDependencySuggestCodeAction+ plId+ verTxtDocId+ suggestions+ haskellFilePath+ cabalFilePath+ gpd+ pure $ InL $ fmap InR actions --- | Handler for hover messages.------ Provides a Handler for displaying message on hover.--- If found that the filtered hover message is a dependency,--- adds a Documentation link.+cabalAddModuleCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+cabalAddModuleCodeAction recorder state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) =+ case List.find CabalAdd.isUnknownModuleDiagnostic diags of+ Just diag ->+ do+ haskellFilePath <- uriToFilePathE uri+ mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath+ case mbCabalFile of+ Nothing -> pure $ InL []+ Just cabalFilePath -> do+ verTextDocId <-+ runActionE "cabalAdd.getVersionedTextDoc" state $+ lift $+ getVersionedTextDoc $+ TextDocumentIdentifier (filePathToUri cabalFilePath)+ (gpd, _) <- runActionE "cabal.cabal-add" state $ useWithStaleE ParseCabalFile $ toNormalizedFilePath cabalFilePath+ actions <-+ CabalAdd.collectModuleInsertionOptions+ (cmapWithPrio LogCabalAdd recorder)+ plId+ verTextDocId+ diag+ cabalFilePath+ gpd+ uri+ pure $ InL $ fmap InR actions+ Nothing -> pure $ InL []++{- | Handler for hover messages.++If the cursor is hovering on a dependency, add a documentation link to that dependency.+-} hover :: PluginMethodHandler IdeState LSP.Method_TextDocumentHover hover ide _ msgParam = do nfp <- getNormalizedFilePathE uri@@ -395,112 +315,36 @@ Nothing -> pure $ InR Null Just txt -> if txt `elem` depsNames- then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt])- else pure $ InR Null- where- cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)- uri = msgParam ^. JL.textDocument . JL.uri-- dependencyName :: Dependency -> T.Text- dependencyName dep = T.pack $ unPackageName $ depPkgName dep-- -- | Removes version requirements like- -- `==1.0.0.0`, `>= 2.1.1` that could be included in- -- hover message. Assumes that the dependency consists- -- of alphanums with dashes in between. Ends with an alphanum.- --- -- Examples:- -- >>> filterVersion "imp-deps>=2.1.1"- -- "imp-deps"- filterVersion :: T.Text -> Maybe T.Text- filterVersion msg = getMatch (msg =~ regex)- where- regex :: T.Text- regex = "([a-zA-Z0-9-]*[a-zA-Z0-9])"-- getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text- getMatch (_, _, _, [dependency]) = Just dependency- getMatch (_, _, _, _) = Nothing -- impossible case-- documentationText :: T.Text -> T.Text- documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")"----- ------------------------------------------------------------------- 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, Generic)-instance Hashable IsCabalFileOfInterest-instance NFData IsCabalFileOfInterest--type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult--data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus- deriving (Eq, Show, 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+ then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt])+ else pure $ InR Null 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+ cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)+ uri = msgParam ^. JL.textDocument . JL.uri -getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)-getCabalFilesOfInterestUntracked = do- OfInterestCabalVar var <- Shake.getIdeGlobalAction- liftIO $ readVar var+ dependencyName :: Dependency -> T.Text+ dependencyName dep = T.pack $ unPackageName $ depPkgName dep -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key]-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))- if prev /= Just v- then do- log' Debug $ LogFOI files- return [toKey IsCabalFileOfInterest f]- else return []- where- log' = logWith recorder+ -- \| Removes version requirements like+ -- `==1.0.0.0`, `>= 2.1.1` that could be included in+ -- hover message. Assumes that the dependency consists+ -- of alphanums with dashes in between. Ends with an alphanum.+ --+ -- Examples:+ -- >>> filterVersion "imp-deps>=2.1.1"+ -- "imp-deps"+ filterVersion :: T.Text -> Maybe T.Text+ filterVersion msg = getMatch (msg =~ regex)+ where+ regex :: T.Text+ regex = "([a-zA-Z0-9-]*[a-zA-Z0-9])" -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key]-deleteFileOfInterest recorder state f = do- OfInterestCabalVar var <- Shake.getIdeGlobalState state- files <- modifyVar' var $ HashMap.delete f- log' Debug $ LogFOI files- return [toKey IsFileOfInterest f]- where- log' = logWith recorder+ getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text+ getMatch (_, _, _, [dependency]) = Just dependency+ getMatch (_, _, _, _) = Nothing -- impossible case + documentationText :: T.Text -> T.Text+ documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")"+ -- ---------------------------------------------------------------- -- Completion -- ----------------------------------------------------------------@@ -532,23 +376,24 @@ Just ctx -> do logWith recorder Debug $ LogCompletionContext ctx pos let completer = Completions.contextToCompleter ctx- let completerData = CompleterTypes.CompleterData- { getLatestGPD = do- -- We decide on useWithStaleFast here, since we mostly care about the file's meta information,- -- thus, a quick response gives us the desired result most of the time.- -- The `withStale` option is very important here, since we often call this rule with invalid cabal files.- mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp- pure $ fmap fst mGPD- , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp- , cabalPrefixInfo = prefInfo- , stanzaName =- case fst ctx of- Types.Stanza _ name -> name- _ -> Nothing- }+ let completerData =+ CompleterTypes.CompleterData+ { getLatestGPD = do+ -- We decide on useWithStaleFast here, since we mostly care about the file's meta information,+ -- thus, a quick response gives us the desired result most of the time.+ -- The `withStale` option is very important here, since we often call this rule with invalid cabal files.+ mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp+ pure $ fmap fst mGPD+ , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp+ , cabalPrefixInfo = prefInfo+ , stanzaName =+ case fst ctx of+ Types.Stanza _ name -> name+ _ -> Nothing+ } completions <- completer completerRecorder completerData pure completions- where- pos = Types.completionCursorPosition prefInfo- context fields = Completions.getContext completerRecorder prefInfo fields- completerRecorder = cmapWithPrio LogCompletions recorder+ where+ pos = Types.completionCursorPosition prefInfo+ context fields = Completions.getContext completerRecorder prefInfo fields+ completerRecorder = cmapWithPrio LogCompletions recorder
− plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs
@@ -1,326 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RecordWildCards #-}--module Ide.Plugin.Cabal.CabalAdd-( findResponsibleCabalFile- , addDependencySuggestCodeAction- , hiddenPackageSuggestion- , cabalAddCommand- , command- , Log-)-where--import Control.Monad (filterM, void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except-import Data.Aeson.Types (FromJSON,- ToJSON, toJSON)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.List.NonEmpty (NonEmpty (..),- fromList)-import Data.String (IsString)-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)-import qualified Data.Text.Encoding as T-import Data.Text.Utf16.Rope.Mixed as Rope-import Development.IDE (IdeState,- getFileContents,- useWithStale)-import Development.IDE.Core.Rules (runAction)-import Distribution.Client.Add as Add-import Distribution.Compat.Prelude (Generic)-import Distribution.PackageDescription (GenericPackageDescription,- packageDescription,- specVersion)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Quirks (patchQuirks)-import qualified Distribution.Pretty as Pretty-import Distribution.Simple.BuildTarget (BuildTarget,- buildTargetComponentName,- readBuildTargets)-import Distribution.Simple.Utils (safeHead)-import Distribution.Verbosity (silent,- verboseNoStderr)-import Ide.Logger-import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..),- ParseCabalFile (..))-import Ide.Plugin.Cabal.Orphans ()-import Ide.Plugin.Error-import Ide.PluginUtils (WithDeletions (SkipDeletions),- diffText,- mkLspCommand)-import Ide.Types (CommandFunction,- CommandId (CommandId),- PluginId,- pluginGetClientCapabilities,- pluginSendRequest)-import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit))-import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),- ClientCapabilities,- CodeAction (CodeAction),- CodeActionKind (CodeActionKind_QuickFix),- Diagnostic (..),- Null (Null),- VersionedTextDocumentIdentifier,- WorkspaceEdit,- toNormalizedFilePath,- type (|?) (InR))-import System.Directory (doesFileExist,- listDirectory)-import System.FilePath (dropFileName,- makeRelative,- splitPath,- takeExtension,- (</>))-import Text.PrettyPrint (render)-import Text.Regex.TDFA--data Log- = LogFoundResponsibleCabalFile FilePath- | LogCalledCabalAddCommand CabalAddCommandParams- | LogCreatedEdit WorkspaceEdit- | LogExecutedCommand- deriving (Show)--instance Pretty Log where- pretty = \case- LogFoundResponsibleCabalFile fp -> "Located the responsible cabal file at " <+> pretty fp- LogCalledCabalAddCommand params -> "Called CabalAdd command with:\n" <+> pretty params- LogCreatedEdit edit -> "Created inplace edit:\n" <+> pretty edit- LogExecutedCommand -> "Executed CabalAdd command"--cabalAddCommand :: IsString p => p-cabalAddCommand = "cabalAdd"--data CabalAddCommandParams =- CabalAddCommandParams { cabalPath :: FilePath- , verTxtDocId :: VersionedTextDocumentIdentifier- , buildTarget :: Maybe String- , dependency :: T.Text- , version :: Maybe T.Text- }- deriving (Generic, Show)- deriving anyclass (FromJSON, ToJSON)--instance Pretty CabalAddCommandParams where- pretty CabalAddCommandParams{..} =- "CabalAdd parameters:" <+> vcat- [ "cabal path:" <+> pretty cabalPath- , "target:" <+> pretty buildTarget- , "dependendency:" <+> pretty dependency- , "version:" <+> pretty version- ]---- | Creates a code action that calls the `cabalAddCommand`,--- using dependency-version suggestion pairs as input.------ Returns disabled action if no cabal files given.------ Takes haskell file and cabal file paths to create a relative path--- to the haskell file, which is used to get a `BuildTarget`.------ In current implementation the dependency is being added to the main found--- build target, but if there will be a way to get all build targets from a file--- it will be possible to support addition to a build target of choice.-addDependencySuggestCodeAction- :: PluginId- -> VersionedTextDocumentIdentifier -- ^ Cabal's versioned text identifier- -> [(T.Text, T.Text)] -- ^ A dependency-version suggestion pairs- -> FilePath -- ^ Path to the haskell file (source of diagnostics)- -> FilePath -- ^ Path to the cabal file (that will be edited)- -> GenericPackageDescription- -> IO [CodeAction]-addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do- buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath- case buildTargets of- -- If there are no build targets found, run `cabal-add` command with default behaviour- [] -> pure $ mkCodeAction cabalFilePath Nothing <$> suggestions- -- Otherwise provide actions for all found targets- targets -> pure $ concat [mkCodeAction cabalFilePath (Just $ buildTargetToStringRepr target) <$>- suggestions | target <- targets]- where- -- | Note the use of `pretty` function.- -- It converts the `BuildTarget` to an acceptable string representation.- -- It will be used in as the input for `cabal-add`'s `executeConfig`.- buildTargetToStringRepr target = render $ Pretty.pretty $ buildTargetComponentName target-- -- | Gives the build targets that are used in the `CabalAdd`.- -- Note the unorthodox usage of `readBuildTargets`:- -- If the relative path to the haskell file is provided,- -- the `readBuildTargets` will return build targets, where this- -- module is mentioned (in exposed-modules or other-modules).- getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget]- getBuildTargets gpd cabalFilePath haskellFilePath = do- let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath- readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath]-- mkCodeAction :: FilePath -> Maybe String -> (T.Text, T.Text) -> CodeAction- mkCodeAction cabalFilePath target (suggestedDep, suggestedVersion) =- let- versionTitle = if T.null suggestedVersion then T.empty else "-" <> suggestedVersion- targetTitle = case target of- Nothing -> T.empty- Just t -> " at " <> T.pack t- title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle- version = if T.null suggestedVersion then Nothing else Just suggestedVersion-- params = CabalAddCommandParams {cabalPath = cabalFilePath- , verTxtDocId = verTxtDocId- , buildTarget = target- , dependency = suggestedDep- , version=version}- command = mkLspCommand plId (CommandId cabalAddCommand) "Add missing dependency" (Just [toJSON params])- in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing---- | Gives a mentioned number of @(dependency, version)@ pairs--- found in the "hidden package" diagnostic message.------ For example, if a ghc error looks like this:------ > "Could not load module ‘Data.List.Split’--- > It is a member of the hidden package ‘split-0.2.5’.--- > Perhaps you need to add ‘split’ to the build-depends in your .cabal file."------ or this if PackageImports extension is used:------ > "Could not find module ‘Data.List.Split’--- > Perhaps you meant--- > Data.List.Split (needs flag -package-id split-0.2.5)"------ It extracts mentioned package names and version numbers.--- In this example, it will be @[("split", "0.2.5")]@------ Also supports messages without a version.------ > "Perhaps you need to add ‘split’ to the build-depends in your .cabal file."------ Will turn into @[("split", "")]@-hiddenPackageSuggestion :: Diagnostic -> [(T.Text, T.Text)]-hiddenPackageSuggestion diag = getMatch (msg =~ regex)- where- msg :: T.Text- msg = _message diag- regex :: T.Text -- TODO: Support multiple packages suggestion- regex =- let regex' = "([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?"- in "It is a member of the hidden package [\8216']" <> regex' <> "[\8217']"- <> "|"- <> "needs flag -package-id " <> regex'- -- Have to do this matching because `Regex.TDFA` doesn't(?) support- -- not-capturing groups like (?:message)- getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [(T.Text, T.Text)]- getMatch (_, _, _, []) = []- getMatch (_, _, _, [dependency, _, cleanVersion, "", "", ""]) = [(dependency, cleanVersion)]- getMatch (_, _, _, ["", "", "", dependency, _, cleanVersion]) = [(dependency, cleanVersion)]- getMatch (_, _, _, _) = []--command :: Recorder (WithPriority Log) -> CommandFunction IdeState CabalAddCommandParams-command recorder state _ params@(CabalAddCommandParams {cabalPath = path, verTxtDocId = verTxtDocId, buildTarget = target, dependency = dep, version = mbVer}) = do- logWith recorder Debug $ LogCalledCabalAddCommand params- let specifiedDep = case mbVer of- Nothing -> dep- Just ver -> dep <> " ^>=" <> ver- caps <- lift pluginGetClientCapabilities- let env = (state, caps, verTxtDocId)- edit <- getDependencyEdit recorder env path target (fromList [T.unpack specifiedDep])- void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())- logWith recorder Debug LogExecutedCommand- pure $ InR Null---- | Constructs prerequisites for the @executeConfig@--- and runs it, given path to the cabal file and a dependency message.--- Given the new contents of the cabal file constructs and returns the @edit@.--- Inspired by @main@ in cabal-add,--- Distribution.Client.Main-getDependencyEdit :: MonadIO m => Recorder (WithPriority Log) -> (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) ->- FilePath -> Maybe String -> NonEmpty String -> ExceptT PluginError m WorkspaceEdit-getDependencyEdit recorder env cabalFilePath buildTarget dependency = do- let (state, caps, verTxtDocId) = env- (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do- contents <- getFileContents $ toNormalizedFilePath cabalFilePath- inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath- inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath- let mbCnfOrigContents = case contents of- (Just txt) -> Just $ encodeUtf8 $ Rope.toText txt- _ -> Nothing- let mbFields = fst <$> inFields- let mbPackDescr = fst <$> inPackDescr- pure (mbCnfOrigContents, mbFields, mbPackDescr)-- -- Check if required info was received,- -- otherwise fall back on other options.- (cnfOrigContents, fields, packDescr) <- do- cnfOrigContents <- case mbCnfOrigContents of- (Just cnfOrigContents) -> pure cnfOrigContents- Nothing -> readCabalFile cabalFilePath- (fields, packDescr) <- case (mbFields, mbPackDescr) of- (Just fields, Just packDescr) -> pure (fields, packDescr)- (_, _) -> case parseCabalFile cabalFilePath cnfOrigContents of- Left err -> throwE $ PluginInternalError $ T.pack err- Right (f ,gpd) -> pure (f, gpd)- pure (cnfOrigContents, fields, packDescr)-- let inputs = do- let rcnfComponent = buildTarget- let specVer = specVersion $ packageDescription packDescr- cmp <- resolveComponent cabalFilePath (fields, packDescr) rcnfComponent- deps <- traverse (validateDependency specVer) dependency- pure (fields, packDescr, cmp, deps)-- (cnfFields, origPackDescr, cnfComponent, cnfDependencies) <- case inputs of- Left err -> throwE $ PluginInternalError $ T.pack err- Right pair -> pure pair-- case executeConfig (validateChanges origPackDescr) (Config {..}) of- Nothing -> throwE $ PluginInternalError $ T.pack $ "Cannot extend build-depends in " ++ cabalFilePath- Just newContents -> do- let edit = diffText caps (verTxtDocId, T.decodeUtf8 cnfOrigContents) (T.decodeUtf8 newContents) SkipDeletions- logWith recorder Debug $ LogCreatedEdit edit- pure edit---- | Given a path to a haskell file, returns the closest cabal file.--- If a package.yaml is present in same directory as the .cabal file, returns nothing, because adding a dependency to a generated cabal file--- will break propagation of changes from package.yaml to cabal files in stack projects.--- If cabal file wasn't found, gives Nothing.-findResponsibleCabalFile :: FilePath -> IO (Maybe FilePath)-findResponsibleCabalFile haskellFilePath = do- let dirPath = dropFileName haskellFilePath- allDirPaths = reverse $ scanl1 (</>) (splitPath dirPath) -- sorted from most to least specific- go allDirPaths- where- go [] = pure Nothing- go (path:ps) = do- objects <- listDirectory path- let objectsWithPaths = map (\obj -> path <> obj) objects- objectsCabalExtension = filter (\c -> takeExtension c == ".cabal") objectsWithPaths- cabalFiles <- filterM (\c -> doesFileExist c) objectsCabalExtension- case safeHead cabalFiles of- Nothing -> go ps- Just cabalFile -> guardAgainstHpack path cabalFile- where- guardAgainstHpack :: FilePath -> FilePath -> IO (Maybe FilePath)- guardAgainstHpack path cabalFile = do- exists <- doesFileExist $ path </> "package.yaml"- if exists then pure Nothing else pure $ Just cabalFile---- | Gives cabal file's contents or throws error.--- Inspired by @readCabalFile@ in cabal-add,--- Distribution.Client.Main------ This is a fallback option!--- Use only if the `GetFileContents` fails.-readCabalFile :: MonadIO m => FilePath -> ExceptT PluginError m ByteString-readCabalFile fileName = do- cabalFileExists <- liftIO $ doesFileExist fileName- if cabalFileExists- then snd . patchQuirks <$> liftIO (B.readFile fileName)- else throwE $ PluginInternalError $ T.pack ("Failed to read cabal file at " <> fileName)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/CodeAction.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Cabal.CabalAdd.CodeAction where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except+import Data.Aeson.Types (toJSON)+import Data.Foldable (asum)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Development.IDE.Core.PluginUtils (uriToFilePathE)+import Development.IDE.Types.Location (Uri)+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import qualified Distribution.Pretty as CabalPretty+import Distribution.Simple.BuildTarget (BuildTarget,+ buildTargetComponentName,+ readBuildTargets)+import Distribution.Utils.Path (getSymbolicPath)+import Distribution.Verbosity (silent,+ verboseNoStderr)+import Ide.Logger+import Ide.Plugin.Cabal.CabalAdd.Types+import Ide.Plugin.Cabal.Completion.Completer.Module (fpToExposedModulePath)+import Ide.Plugin.Cabal.Orphans ()+import Ide.Plugin.Error+import Ide.PluginUtils (mkLspCommand)+import Ide.Types (CommandId (CommandId),+ PluginId)++import Control.Lens ((^.))+import qualified Language.LSP.Protocol.Lens as JL+import Language.LSP.Protocol.Types (CodeActionKind (..),+ VersionedTextDocumentIdentifier)+import qualified Language.LSP.Protocol.Types as J+import System.FilePath+import Text.PrettyPrint (render)+import Text.Regex.TDFA++--------------------------------------------+-- Add module to cabal file+--------------------------------------------++{- | Takes a path to a cabal file, a module path in exposed module syntax+ and the contents of the cabal file and generates all possible+ code actions for inserting the module into the cabal file+ with the given contents.+-}+collectModuleInsertionOptions ::+ (MonadIO m) =>+ Recorder (WithPriority Log) ->+ PluginId ->+ VersionedTextDocumentIdentifier ->+ J.Diagnostic ->+ -- | The file path of the cabal file to insert the new module into+ FilePath ->+ -- | The generic package description of the cabal file to insert the new module into.+ GenericPackageDescription ->+ -- | The URI of the unknown haskell file/new module to insert into the cabal file.+ Uri ->+ ExceptT PluginError m [J.CodeAction]+collectModuleInsertionOptions _ plId txtDocIdentifier diag cabalFilePath gpd haskellFilePathURI = do+ haskellFilePath <- uriToFilePathE haskellFilePathURI+ let configs = concatMap (mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath) (makeStanzaItems gpd)+ pure $ map (mkCodeActionForModulePath plId diag) configs+ where+ makeStanzaItems :: GenericPackageDescription -> [StanzaItem]+ makeStanzaItems gpd =+ mainLibItem pd+ ++ libItems pd+ ++ executableItems pd+ ++ testSuiteItems pd+ ++ benchmarkItems pd+ where+ pd = flattenPackageDescription gpd++{- | Takes a buildInfo of a cabal file component as defined in the generic package description,+ and translates it to filepaths of the component's hsSourceDirs,+ to be processed for adding modules to exposed-, or other-modules fields in a cabal file.+-}+buildInfoToHsSourceDirs :: BuildInfo -> [FilePath]+buildInfoToHsSourceDirs buildInfo = map getSymbolicPath hsSourceDirs'+ where+ hsSourceDirs' = hsSourceDirs buildInfo++{- | Takes the path to the cabal file to insert the module into,+ the module path to be inserted, and a stanza representation.++ Returns a list of module insertion configs, where each config+ represents a possible place to insert the module.+-}+mkModuleInsertionConfig :: VersionedTextDocumentIdentifier -> FilePath -> FilePath -> StanzaItem -> [ModuleInsertionConfig]+mkModuleInsertionConfig txtDocIdentifier cabalFilePath haskellFilePath (StanzaItem{..}) = do+ case mkRelativeModulePathM siHsSourceDirs cabalFilePath haskellFilePath of+ Just processedModPath ->+ [modInsertItem processedModPath "other-modules"]+ ++ [modInsertItem processedModPath "exposed-modules" | CLibName _ <- [siComponent]]+ _ -> []+ where+ modInsertItem :: T.Text -> T.Text -> ModuleInsertionConfig+ modInsertItem modPath label =+ ModuleInsertionConfig+ { targetFile = cabalFilePath+ , moduleToInsert = modPath+ , modVerTxtDocId = txtDocIdentifier+ , insertionStanza = siComponent+ , insertionLabel = label+ }++mkCodeActionForModulePath :: PluginId -> J.Diagnostic -> ModuleInsertionConfig -> J.CodeAction+mkCodeActionForModulePath plId diag insertionConfig =+ J.CodeAction+ { _title = "Add to " <> label <> " as " <> fieldName+ , _kind = Just CodeActionKind_Refactor+ , _diagnostics = Just [diag]+ , _isPreferred = Nothing+ , _disabled = Nothing+ , _edit = Nothing+ , _command = Just command+ , _data_ = Nothing+ }+ where+ fieldName = insertionLabel insertionConfig+ command = mkLspCommand plId (CommandId cabalAddModuleCommandId) "Add missing module" (Just [toJSON insertionConfig])+ label = T.pack $ CabalPretty.prettyShow $ insertionStanza insertionConfig++{- | Takes a list of source subdirectories, a cabal source path and a haskell filepath+ and returns a path to the module in exposed module syntax.+ The path will be relative to one of the subdirectories, in case the module is contained within one of them.+-}+mkRelativeModulePathM :: [FilePath] -> FilePath -> FilePath -> Maybe T.Text+mkRelativeModulePathM hsSourceDirs cabalSrcPath' haskellFilePath =+ asum $+ map+ ( \srcDir -> do+ let relMP = makeRelative (normalise (cabalSrcPath </> srcDir)) haskellFilePath+ if relMP == haskellFilePath then Nothing else Just $ fpToExposedModulePath cabalSrcPath relMP+ )+ hsSourceDirs+ where+ cabalSrcPath = takeDirectory cabalSrcPath'++isUnknownModuleDiagnostic :: J.Diagnostic -> Bool+isUnknownModuleDiagnostic diag = (msg =~ regex)+ where+ msg :: T.Text+ msg = diag ^. JL.message+ regex :: T.Text+ regex = "Loading the module [\8216'][^\8217']*[\8217'] failed."++--------------------------+-- Below are several utility functions which create a StanzaItem for each of the possible Stanzas,+-- these all have specific constructors we need to match, so we can't generalise this process well.+--------------------------++benchmarkItems :: PackageDescription -> [StanzaItem]+benchmarkItems pd =+ map+ ( \benchmark ->+ StanzaItem+ { siComponent = CBenchName $ benchmarkName benchmark+ , siHsSourceDirs = buildInfoToHsSourceDirs $ benchmarkBuildInfo benchmark+ }+ )+ (benchmarks pd)++testSuiteItems :: PackageDescription -> [StanzaItem]+testSuiteItems pd =+ map+ ( \testSuite ->+ StanzaItem+ { siComponent = CTestName $ testName testSuite+ , siHsSourceDirs = buildInfoToHsSourceDirs $ testBuildInfo testSuite+ }+ )+ (testSuites pd)++executableItems :: PackageDescription -> [StanzaItem]+executableItems pd =+ map+ ( \executable ->+ StanzaItem+ { siComponent = CExeName $ exeName executable+ , siHsSourceDirs = buildInfoToHsSourceDirs $ buildInfo executable+ }+ )+ (executables pd)++libItems :: PackageDescription -> [StanzaItem]+libItems pd =+ mapMaybe+ ( \subLib ->+ case libName subLib of+ LSubLibName compName ->+ Just+ StanzaItem+ { siComponent = CLibName $ LSubLibName compName+ , siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo subLib+ }+ _ -> Nothing+ )+ (subLibraries pd)++mainLibItem :: PackageDescription -> [StanzaItem]+mainLibItem pd =+ case library pd of+ Just lib ->+ [ StanzaItem+ { siComponent = CLibName LMainLibName+ , siHsSourceDirs = buildInfoToHsSourceDirs $ libBuildInfo lib+ }+ ]+ Nothing -> []++--------------------------------------------+-- Add dependency to a cabal file+--------------------------------------------++{- | Creates a code action that calls the `cabalAddCommand`,+ using dependency-version suggestion pairs as input.++ Returns disabled action if no cabal files given.++ Takes haskell and cabal file paths to create a relative path+ to the haskell file, which is used to get a `BuildTarget`.+-}+addDependencySuggestCodeAction ::+ PluginId ->+ -- | Cabal's versioned text identifier+ VersionedTextDocumentIdentifier ->+ -- | A dependency-version suggestion pairs+ [(T.Text, T.Text)] ->+ -- | Path to the haskell file (source of diagnostics)+ FilePath ->+ -- | Path to the cabal file (that will be edited)+ FilePath ->+ GenericPackageDescription ->+ IO [J.CodeAction]+addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do+ buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath+ case buildTargets of+ -- If there are no build targets found, run the `cabal-add` command with default behaviour+ [] -> pure $ mkCodeActionForDependency cabalFilePath Nothing <$> suggestions+ -- Otherwise provide actions for all found targets+ targets ->+ pure $+ concat+ [ mkCodeActionForDependency cabalFilePath (Just $ buildTargetToStringRepr target)+ <$> suggestions+ | target <- targets+ ]+ where+ {- | Note the use of the `pretty` function.+ It converts the `BuildTarget` to an acceptable string representation.+ It will be used as the input for `cabal-add`'s `executeConfig`.+ -}+ buildTargetToStringRepr target = render $ CabalPretty.pretty $ buildTargetComponentName target++ {- | Finds the build targets that are used in `cabal-add`.+ Note the unorthodox usage of `readBuildTargets`:+ If the relative path to the haskell file is provided,+ `readBuildTargets` will return the build targets, this+ module is mentioned in (either exposed-modules or other-modules).+ -}+ getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget]+ getBuildTargets gpd cabalFilePath haskellFilePath = do+ let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath+ readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath]++ mkCodeActionForDependency :: FilePath -> Maybe String -> (T.Text, T.Text) -> J.CodeAction+ mkCodeActionForDependency cabalFilePath target (suggestedDep, suggestedVersion) =+ let+ versionTitle = if T.null suggestedVersion then T.empty else "-" <> suggestedVersion+ targetTitle = case target of+ Nothing -> T.empty+ Just t -> " at " <> T.pack t+ title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle+ version = if T.null suggestedVersion then Nothing else Just suggestedVersion++ params =+ CabalAddDependencyCommandParams+ { depCabalPath = cabalFilePath+ , depVerTxtDocId = verTxtDocId+ , depBuildTarget = target+ , depDependency = suggestedDep+ , depVersion = version+ }+ command = mkLspCommand plId (CommandId cabalAddDependencyCommandId) "Add dependency" (Just [toJSON params])+ in+ J.CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing++{- | Gives a mentioned number of @(dependency, version)@ pairs+found in the "hidden package" diagnostic message.++For example, if a ghc error looks like this:++> "Could not load module ‘Data.List.Split’+> It is a member of the hidden package ‘split-0.2.5’.+> Perhaps you need to add ‘split’ to the build-depends in your .cabal file."++or this if PackageImports extension is used:++> "Could not find module ‘Data.List.Split’+> Perhaps you meant+> Data.List.Split (needs flag -package-id split-0.2.5)"++It extracts mentioned package names and version numbers.+In this example, it will be @[("split", "0.2.5")]@++Also supports messages without a version.++> "Perhaps you need to add ‘split’ to the build-depends in your .cabal file."++Will turn into @[("split", "")]@+-}+hiddenPackageSuggestion :: J.Diagnostic -> [(T.Text, T.Text)]+hiddenPackageSuggestion diag = getMatch (msg =~ regex)+ where+ msg :: T.Text+ msg = diag ^. JL.message+ regex :: T.Text+ regex =+ let regex' = "([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?"+ in "It is a member of the hidden package [\8216']"+ <> regex'+ <> "[\8217']"+ <> "|"+ <> "needs flag -package-id "+ <> regex'+ -- Have to do this matching because `Regex.TDFA` doesn't(?) support+ -- not-capturing groups like (?:message)+ getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [(T.Text, T.Text)]+ getMatch (_, _, _, []) = []+ getMatch (_, _, _, [dependency, _, cleanVersion, "", "", ""]) = [(dependency, cleanVersion)]+ getMatch (_, _, _, ["", "", "", dependency, _, cleanVersion]) = [(dependency, cleanVersion)]+ getMatch (_, _, _, _) = []
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Cabal.CabalAdd.Command (+ cabalAddDependencyCommandId,+ cabalAddModuleCommandId,+ addDependencyCommand,+ addModuleCommand,+ Log,+)+where++import Control.Monad (void)+import Control.Monad.Except (modifyError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.List.NonEmpty (singleton)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Encoding as T+import Data.Text.Utf16.Rope.Mixed as Rope+import Development.IDE.Core.FileStore (getFileContents)+import Development.IDE.Core.Rules (IdeState)+import Development.IDE.Core.Service (runAction)+import Development.IDE.Core.Shake (useWithStale)+import Distribution.Client.Add as Add+import Distribution.Fields (Field)+import Distribution.PackageDescription+import Distribution.Parsec.Position (Position)+import qualified Distribution.Pretty as CabalPretty+import Ide.Logger+import Ide.Plugin.Cabal.CabalAdd.Types+import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..),+ ParseCabalFile (..))+import Ide.Plugin.Cabal.Files+import Ide.Plugin.Cabal.Orphans ()+import Ide.Plugin.Error+import Ide.PluginUtils (WithDeletions (SkipDeletions),+ diffText)+import Ide.Types (CommandFunction,+ pluginGetClientCapabilities,+ pluginSendRequest)+import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit))+import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),+ ClientCapabilities,+ Null (Null),+ VersionedTextDocumentIdentifier,+ WorkspaceEdit,+ toNormalizedFilePath,+ type (|?) (InR))++--------------------------------------------+-- Add module to cabal file+--------------------------------------------++addModuleCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState ModuleInsertionConfig+addModuleCommand recorder state _ params@(ModuleInsertionConfig{..}) = do+ logWith recorder Debug $ LogCalledCabalAddModuleCommand params+ caps <- lift pluginGetClientCapabilities+ let env = (state, caps, modVerTxtDocId)+ edit <- getModuleEdit recorder env targetFile insertionStanza (T.unpack insertionLabel) (T.unpack moduleToInsert)+ void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+ logWith recorder Debug LogExecutedCommand+ pure $ InR Null++{- | Constructs prerequisites for the @executeConfig@+ and runs it, given path to the cabal file and a dependency message.+ Given the new contents of the cabal file constructs and returns the @edit@.++ Inspired by @main@ in cabal-add, Distribution.Client.Main+-}+getModuleEdit ::+ forall m.+ (MonadIO m) =>+ Recorder (WithPriority Log) ->+ (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) ->+ -- | The cabal file to edit.+ FilePath ->+ -- | The component to add the module to.+ ComponentName ->+ -- | The specific field in the component to add the module to.+ String ->+ -- | The module to add.+ String ->+ ExceptT PluginError m WorkspaceEdit+getModuleEdit recorder env cabalFilePath stanza targetFieldStr modulePath =+ mkCabalAddConfig+ recorder+ env+ cabalFilePath+ mkConfig+ where+ mkConfig :: (ByteString -> [Field Position] -> GenericPackageDescription -> ExceptT PluginError m AddConfig)+ mkConfig cnfOrigContents fields packDescr = do+ compName <-+ case Add.resolveComponent cabalFilePath (fields, packDescr) $ Just $ CabalPretty.prettyShow stanza of+ Right x -> pure x+ Left err -> do+ logWith recorder Info $ LogFailedToResolveComponent err+ throwE $ PluginInternalError $ T.pack err+ pure $+ AddConfig+ { cnfOrigContents = cnfOrigContents+ , cnfFields = fields+ , cnfComponent = compName+ , cnfTargetField = if targetFieldStr == "exposed-modules" then ExposedModules else OtherModules+ , cnfAdditions = singleton $ B.pack modulePath+ }++--------------------------------------------+-- Add build dependency to cabal file+--------------------------------------------++addDependencyCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState CabalAddDependencyCommandParams+addDependencyCommand recorder state _ params@(CabalAddDependencyCommandParams{..}) = do+ logWith recorder Debug $ LogCalledCabalAddDependencyCommand params+ let specifiedDep = case depVersion of+ Nothing -> depDependency+ Just ver -> depDependency <> " ^>=" <> ver+ caps <- lift pluginGetClientCapabilities+ let env = (state, caps, depVerTxtDocId)+ edit <- getDependencyEdit recorder env depCabalPath depBuildTarget (T.unpack specifiedDep)+ void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+ logWith recorder Debug LogExecutedCommand+ pure $ InR Null++{- | Constructs prerequisites for the @executeConfig@+ and runs it, given path to the cabal file and a dependency message.+ Given the new contents of the cabal file constructs and returns the @edit@.+ Inspired by @main@ in cabal-add,+ Distribution.Client.Main+-}+getDependencyEdit ::+ forall m.+ (MonadIO m) =>+ Recorder (WithPriority Log) ->+ (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) ->+ FilePath ->+ Maybe String ->+ String ->+ ExceptT PluginError m WorkspaceEdit+getDependencyEdit recorder env cabalFilePath buildTarget dependency =+ mkCabalAddConfig recorder env cabalFilePath mkConfig+ where+ mkConfig :: (ByteString -> [Field Position] -> GenericPackageDescription -> ExceptT PluginError m AddConfig)+ mkConfig cnfOrigContents fields packDescr = do+ let specVer = specVersion $ packageDescription packDescr+ (deps, compName) <-+ modifyError (\t -> PluginInternalError $ T.pack t) $ do+ deps <- validateDependency specVer dependency+ compName <- resolveComponent cabalFilePath (fields, packDescr) buildTarget+ pure (deps, compName)+ pure $+ AddConfig+ { cnfOrigContents = cnfOrigContents+ , cnfFields = fields+ , cnfComponent = compName+ , cnfTargetField = BuildDepends+ , cnfAdditions = singleton deps+ }++--------------------------------------------+-- Shared Functions+--------------------------------------------++mkCabalAddConfig ::+ (MonadIO m) =>+ Recorder (WithPriority Log) ->+ (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) ->+ -- | The cabal file to edit+ FilePath ->+ -- | Callback to allow configuration of 'AddConfig' to be used by `cabal-add`+ ( ByteString ->+ [Field Position] ->+ GenericPackageDescription ->+ ExceptT PluginError m AddConfig+ ) ->+ ExceptT PluginError m WorkspaceEdit+mkCabalAddConfig recorder env cabalFilePath mkConfig = do+ let (state, caps, verTxtDocId) = env+ (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do+ contents <- getFileContents $ toNormalizedFilePath cabalFilePath+ inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath+ inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath+ let mbCnfOrigContents = case contents of+ (Just txt) -> Just $ encodeUtf8 $ Rope.toText txt+ _ -> Nothing+ let mbFields = fst <$> inFields+ let mbPackDescr = fst <$> inPackDescr+ pure (mbCnfOrigContents, mbFields, mbPackDescr)++ -- Check if required info was received,+ -- otherwise fall back on other options.+ (cnfOrigContents, fields, packDescr) <- do+ cnfOrigContents <- case mbCnfOrigContents of+ (Just cnfOrigContents) -> pure cnfOrigContents+ Nothing -> readCabalFile cabalFilePath+ (fields, packDescr) <- case (mbFields, mbPackDescr) of+ (Just fields, Just packDescr) -> pure (fields, packDescr)+ (_, _) -> case parseCabalFile cabalFilePath cnfOrigContents of+ Left err -> throwE $ PluginInternalError $ T.pack err+ Right (f, gpd) -> pure (f, gpd)+ pure (cnfOrigContents, fields, packDescr)++ cabalAddConfig <- mkConfig cnfOrigContents fields packDescr++ case executeAddConfig (validateChanges packDescr) cabalAddConfig of+ Nothing ->+ throwE $+ PluginInternalError $+ T.pack $+ "Cannot extend "+ ++ show (cnfTargetField cabalAddConfig)+ ++ " of "+ ++ case (cnfComponent cabalAddConfig) of+ Right compName -> showComponentName compName+ Left commonStanza -> show commonStanza+ ++ " in "+ ++ cabalFilePath+ Just newContents -> do+ let edit = diffText caps (verTxtDocId, T.decodeUtf8 cnfOrigContents) (T.decodeUtf8 newContents) SkipDeletions+ logWith recorder Debug $ LogCreatedEdit edit+ pure edit
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Types.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Cabal.CabalAdd.Types where++import Data.Aeson.Types (FromJSON, ToJSON)+import Data.String (IsString)+import qualified Data.Text as T+import Distribution.Compat.Prelude (Generic)+import Distribution.PackageDescription+import Ide.Logger+import Ide.Plugin.Cabal.Orphans ()+import Language.LSP.Protocol.Types++data Log+ = LogFoundResponsibleCabalFile FilePath+ | LogCalledCabalAddDependencyCommand CabalAddDependencyCommandParams+ | LogCalledCabalAddModuleCommand ModuleInsertionConfig+ | LogCreatedEdit WorkspaceEdit+ | LogExecutedCommand+ | LogFailedToResolveComponent String+ deriving (Show)++instance Pretty Log where+ pretty = \case+ LogFoundResponsibleCabalFile fp -> "Located the responsible cabal file at " <+> pretty fp+ LogCalledCabalAddDependencyCommand params -> "Called CabalAddDependency command with:\n" <+> pretty params+ LogCalledCabalAddModuleCommand params -> "Called CabalAddModule command with:\n" <+> pretty params+ LogCreatedEdit edit -> "Created inplace edit:\n" <+> pretty edit+ LogExecutedCommand -> "Executed CabalAdd command"+ LogFailedToResolveComponent cS -> "Failed to resolve component in CabalAdd with error:" <+> viaShow cS++cabalAddDependencyCommandId :: (IsString p) => p+cabalAddDependencyCommandId = "cabalAddDependency"++cabalAddModuleCommandId :: (IsString p) => p+cabalAddModuleCommandId = "cabalAddModule"++-- | Relevant data needed to add a module to a cabal file.+--+-- This will be sent as json to the client with a code action we offer to add this dependency to a cabal file.+-- If the user decides to execute the corresponding code action, the client sends us this data again, and we then+-- use it to execute the `CabalAddDependencyCommand`.+data ModuleInsertionConfig = ModuleInsertionConfig+ { targetFile :: FilePath+ -- ^ The file we want to insert information about the new module into.+ , moduleToInsert :: T.Text+ -- ^ The module name of the module to be inserted into the targetFile at the insertionPosition.+ , modVerTxtDocId :: VersionedTextDocumentIdentifier+ , insertionStanza :: ComponentName+ -- ^ Which stanza the module will be inserted into.+ , insertionLabel :: T.Text+ -- ^ A label which describes which field the module will be inserted into.+ }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (FromJSON, ToJSON)++instance Pretty ModuleInsertionConfig where+ pretty ModuleInsertionConfig{..} =+ "CabalAddModule parameters:"+ <+> vcat+ [ "cabal path:" <+> pretty targetFile+ , "target:" <+> pretty moduleToInsert+ , "stanza:" <+> viaShow insertionStanza+ , "label:" <+> pretty insertionLabel+ ]++-- | Contains all source directories of a stanza with the name of the first parameter.+data StanzaItem = StanzaItem+ { siComponent :: ComponentName+ , siHsSourceDirs :: [FilePath]+ }+ deriving (Show)++-- | Relevant data needed to add a dependency to a cabal file.+--+-- This will be sent as json to the client with a code action we offer to add this dependency to a cabal file.+-- If the user decides to execute the corresponding code action, the client sends us this data again, and we then+-- use it to execute the `CabalAddDependencyCommand`.+data CabalAddDependencyCommandParams = CabalAddDependencyCommandParams+ { depCabalPath :: FilePath+ , depVerTxtDocId :: VersionedTextDocumentIdentifier+ , depBuildTarget :: Maybe String+ , depDependency :: T.Text+ , depVersion :: Maybe T.Text+ }+ deriving (Generic, Show)+ deriving anyclass (FromJSON, ToJSON)++instance Pretty CabalAddDependencyCommandParams where+ pretty CabalAddDependencyCommandParams{..} =+ "CabalAddDependency parameters:"+ <+> vcat+ [ "cabal path:" <+> pretty depCabalPath+ , "target:" <+> pretty depBuildTarget+ , "dependendency:" <+> pretty depDependency+ , "version:" <+> pretty depVersion+ ]
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Files.hs view
@@ -0,0 +1,56 @@+module Ide.Plugin.Cabal.Files where++import Control.Monad (filterM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import Distribution.PackageDescription.Quirks (patchQuirks)+import Distribution.Simple.Utils (safeHead)+import Ide.Plugin.Cabal.Orphans ()+import Ide.Plugin.Error+import System.Directory (doesFileExist,+ listDirectory)+import System.FilePath++{- | Given a path to a haskell file, returns the closest cabal file.+ If a package.yaml is present in same directory as the .cabal file, returns nothing,+ because adding a dependency to a generated cabal file will break propagation of changes+ from package.yaml to cabal files in stack projects.+ If cabal file wasn't found, returns Nothing.+-}+findResponsibleCabalFile :: FilePath -> IO (Maybe FilePath)+findResponsibleCabalFile haskellFilePath = do+ let dirPath = dropFileName haskellFilePath+ allDirPaths = reverse $ scanl1 (</>) (splitPath dirPath) -- sorted from most to least specific+ go allDirPaths+ where+ go [] = pure Nothing+ go (path : ps) = do+ objects <- listDirectory path+ let objectsWithPaths = map (\obj -> path <> obj) objects+ objectsCabalExtension = filter (\c -> takeExtension c == ".cabal") objectsWithPaths+ cabalFiles <- filterM (\c -> doesFileExist c) objectsCabalExtension+ case safeHead cabalFiles of+ Nothing -> go ps+ Just cabalFile -> guardAgainstHpack path cabalFile+ where+ guardAgainstHpack :: FilePath -> FilePath -> IO (Maybe FilePath)+ guardAgainstHpack path cabalFile = do+ exists <- doesFileExist $ path </> "package.yaml"+ if exists then pure Nothing else pure $ Just cabalFile++{- | Gives a cabal file's contents or throws error.++ Inspired by @readCabalFile@ in cabal-add, Distribution.Client.Main++ This is a fallback option!+ Use only if the `GetFileContents` fails.+-}+readCabalFile :: (MonadIO m) => FilePath -> ExceptT PluginError m ByteString+readCabalFile fileName = do+ cabalFileExists <- liftIO $ doesFileExist fileName+ if cabalFileExists+ then snd . patchQuirks <$> liftIO (B.readFile fileName)+ else throwE $ PluginInternalError $ T.pack ("Failed to read cabal file at " <> fileName)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Ide.Plugin.Cabal.OfInterest (ofInterestRules, getCabalFilesOfInterestUntracked, addFileOfInterest, deleteFileOfInterest, kick, Log) where++import Control.Concurrent.Strict+import Control.DeepSeq+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Proxy+import qualified Data.Text ()+import Development.IDE as D+import qualified Development.IDE.Core.Shake as Shake+import Development.IDE.Graph (Key, alwaysRerun)+import Development.IDE.Types.Shake (toKey)+import GHC.Generics+import qualified Ide.Plugin.Cabal.Completion.Types as Types+import Ide.Plugin.Cabal.Orphans ()++data Log+ = LogShake Shake.Log+ | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus)+ deriving (Show)++instance Pretty Log where+ pretty = \case+ LogShake log' -> pretty log'+ LogFOI files ->+ "Set files of interest to:" <+> viaShow files++-- ----------------------------------------------------------------+-- 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, Generic)+instance Hashable IsCabalFileOfInterest+instance NFData IsCabalFileOfInterest++type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult++data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus+ deriving (Eq, Show, 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 [Key]+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))+ if prev /= Just v+ then do+ log' Debug $ LogFOI files+ return [toKey IsCabalFileOfInterest f]+ else return []+ where+ log' = logWith recorder++deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key]+deleteFileOfInterest recorder state f = do+ OfInterestCabalVar var <- Shake.getIdeGlobalState state+ files <- modifyVar' var $ HashMap.delete f+ log' Debug $ LogFOI files+ return [toKey IsFileOfInterest f]+ 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+ Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs view
@@ -1,8 +1,14 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Ide.Plugin.Cabal.Orphans where import Control.DeepSeq+import Data.Aeson+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.Text as T import Distribution.Fields.Field-import Distribution.Parsec.Position+import Distribution.PackageDescription (ComponentName)+import Distribution.Parsec+import Distribution.Pretty (prettyShow) -- ---------------------------------------------------------------- -- Cabal-syntax orphan instances we need sometimes@@ -22,3 +28,12 @@ rnf (SecArgName ann bs) = rnf ann `seq` rnf bs rnf (SecArgStr ann bs) = rnf ann `seq` rnf bs rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs++instance ToJSON ComponentName where+ toJSON = Aeson.String . T.pack . prettyShow++instance FromJSON ComponentName where+ parseJSON = Aeson.withText "ComponentName" $ \t ->+ case eitherParsec (T.unpack t) of+ Left err -> Aeson.parseFail err+ Right r -> pure r
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs view
@@ -22,9 +22,9 @@ parseCabalFileContents :: BS.ByteString -- ^ UTF-8 encoded bytestring- -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription)+ -> ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) parseCabalFileContents bs =- pure $ runParseResult (parseGenericPackageDescription bs)+ runParseResult (parseGenericPackageDescription bs) readCabalFields :: NormalizedFilePath ->
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Ide.Plugin.Cabal.Rules (cabalRules, Log) where++import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import qualified Data.Maybe as Maybe+import qualified Data.Text ()+import qualified Data.Text as T+import qualified Data.Text.Encoding as Encoding+import Data.Text.Utf16.Rope.Mixed as Rope+import Development.IDE as D+import qualified Development.IDE.Core.Shake as Shake+import qualified Distribution.CabalSpecVersion as Cabal+import qualified Distribution.Fields as Syntax+import Distribution.Parsec.Error+import qualified Ide.Plugin.Cabal.Completion.Data as Data+import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections),+ ParseCabalFields (..),+ ParseCabalFile (..))+import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics+import qualified Ide.Plugin.Cabal.OfInterest as OfInterest+import Ide.Plugin.Cabal.Orphans ()+import qualified Ide.Plugin.Cabal.Parse as Parse+import Ide.Types+import Text.Regex.TDFA++data Log+ = LogModificationTime NormalizedFilePath FileVersion+ | LogShake Shake.Log+ | LogOfInterest OfInterest.Log+ | LogDocSaved Uri+ deriving (Show)++instance Pretty Log where+ pretty = \case+ LogShake log' -> pretty log'+ LogOfInterest log' -> pretty log'+ LogModificationTime nfp modTime ->+ "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime)+ LogDocSaved uri ->+ "Saved text document:" <+> pretty (getUri uri)++cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+cabalRules recorder plId = do+ -- Make sure we initialise the cabal files-of-interest.+ OfInterest.ofInterestRules (cmapWithPrio LogOfInterest recorder)+ -- Rule to produce diagnostics for cabal files.+ define (cmapWithPrio LogShake recorder) $ \ParseCabalFields 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 $ Rope.toText sources+ Nothing -> do+ liftIO $ BS.readFile $ fromNormalizedFilePath file++ case Parse.readCabalFields file contents of+ Left _ ->+ pure ([], Nothing)+ Right fields ->+ pure ([], Just fields)++ define (cmapWithPrio LogShake recorder) $ \ParseCabalCommonSections file -> do+ fields <- use_ ParseCabalFields file+ let commonSections =+ Maybe.mapMaybe+ ( \case+ commonSection@(Syntax.Section (Syntax.Name _ "common") _ _) -> Just commonSection+ _ -> Nothing+ )+ fields+ pure ([], Just commonSections)++ define (cmapWithPrio LogShake recorder) $ \ParseCabalFile 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 $ Rope.toText sources+ Nothing -> do+ liftIO $ BS.readFile $ fromNormalizedFilePath file++ -- Instead of fully reparsing the sources to get a 'GenericPackageDescription',+ -- we would much rather re-use the already parsed results of 'ParseCabalFields'.+ -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''+ -- which allows us to resume the parsing pipeline with '[Field Position]'.+ let (pWarnings, pm) = Parse.parseCabalFileContents contents+ let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings+ case pm of+ Left (_cabalVersion, pErrorNE) -> do+ let regexUnknownCabalBefore310 :: T.Text+ -- We don't support the cabal version, this should not be an error, as the+ -- user did not do anything wrong. Instead we cast it to a warning+ regexUnknownCabalBefore310 = "Unsupported cabal-version [0-9]+.[0-9]*"+ regexUnknownCabalVersion :: T.Text+ regexUnknownCabalVersion = "Unsupported cabal format version in cabal-version field: [0-9]+.[0-9]+"+ unsupportedCabalHelpText =+ unlines+ [ "The used `cabal-version` is not fully supported by this `HLS` binary."+ , "Either the `cabal-version` is unknown, or too new for this executable."+ , "This means that some functionality might not work as expected."+ , "If you face any issues, try downgrading to a supported `cabal-version` or upgrading `HLS` if possible."+ , ""+ , "Supported versions are: "+ <> List.intercalate+ ", "+ (fmap Cabal.showCabalSpecVersion Data.supportedCabalVersions)+ ]+ errorDiags =+ NE.toList $+ NE.map+ ( \pe@(PError pos text) ->+ if any+ (text =~)+ [ regexUnknownCabalBefore310+ , regexUnknownCabalVersion+ ]+ then+ Diagnostics.warningDiagnostic+ file+ ( Syntax.PWarning Syntax.PWTOther pos $+ unlines+ [ text+ , unsupportedCabalHelpText+ ]+ )+ else Diagnostics.errorDiagnostic file pe+ )+ 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.+ OfInterest.kick+ where+ log' = logWith recorder
plugins/hls-cabal-plugin/test/CabalAdd.hs view
@@ -1,56 +1,112 @@-{-# LANGUAGE OverloadedStrings #-}-+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} module CabalAdd (- cabalAddTests,+ cabalAddDependencyTests,+ cabalAddModuleTests, ) where -import Control.Lens ((^.))-import Control.Lens.Fold ((^?))-import qualified Data.Maybe as Maybe-import qualified Data.Text as T-import qualified Data.Text.Internal.Search as T-import Distribution.Utils.Generic (safeHead)-import Ide.Plugin.Cabal.CabalAdd (hiddenPackageSuggestion)-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Types (Diagnostic (..), mkRange)+import Control.Lens ((^.))+import Control.Lens.Fold ((^?))+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Internal.Search as T+import Distribution.ModuleName (fromString)+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import qualified Distribution.Pretty as Pretty+import Distribution.Types.Component+import Distribution.Utils.Generic (safeHead)+import Ide.Plugin.Cabal.CabalAdd.CodeAction (hiddenPackageSuggestion)+import Ide.Plugin.Cabal.Parse (parseCabalFileContents)+import qualified Language.LSP.Protocol.Lens as L+import qualified Language.LSP.Protocol.Types as J import System.FilePath-import Test.Hls (Session, TestTree, _R, anyMessage,- assertEqual, documentContents,- executeCodeAction,- getAllCodeActions,- getDocumentEdit, liftIO, openDoc,- skipManyTill, testCase, testGroup,- waitForDiagnosticsFrom, (@?=))+import Test.Hls import Utils -cabalAddTests :: TestTree-cabalAddTests =+cabalAddModuleTests :: TestTree+cabalAddModuleTests =+ testGroup+ "Add Module"+ [ runHaskellTestCaseSession "Add to benchmark" ("cabal-add-module" </> "library") $ do+ let compName = CBenchName "test1"+ pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName+ checkModuleAddedTo pd "Main" compName+ , runHaskellTestCaseSession "Add to executable" ("cabal-add-module" </> "library") $ do+ let compName = CExeName "test"+ pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName+ checkModuleAddedTo pd "Main" compName+ , runHaskellTestCaseSession "Add to test-suite" ("cabal-add-module" </> "library") $ do+ let compName = CTestName "test2"+ pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName+ checkModuleAddedTo pd "Main" compName+ , runHaskellTestCaseSession "Add to library" ("cabal-add-module" </> "library") $ do+ let compName = CLibName $ LSubLibName "test3"+ pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName+ checkModuleAddedTo pd "Main" compName+ , runHaskellTestCaseSession "Add to main library" ("cabal-add-module" </> "library") $ do+ let compName = CLibName LMainLibName+ pd <- generateAddDependencyTestSession "test.cabal" "Main.hs" compName+ checkModuleAddedTo pd "Main" compName+ ]+ where+ generateAddDependencyTestSession :: FilePath -> FilePath -> ComponentName -> Session PackageDescription+ generateAddDependencyTestSession cabalFile haskellFile compName = do+ haskellDoc <- openDoc haskellFile "haskell"+ cabalDoc <- openDoc cabalFile "cabal"+ _ <- waitForDiagnosticsFrom haskellDoc+ cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions haskellDoc+ let selectedCas = filter (\ca -> (T.pack $ "Add to " <> Pretty.prettyShow compName <> " ") `T.isPrefixOf` (ca ^. L.title)) cas+ mapM_ executeCodeAction $ selectedCas+ _ <- skipManyTill anyMessage $ getDocumentEdit cabalDoc -- Wait for the changes in cabal file+ contents <- documentContents cabalDoc+ case parseCabalFileContents $ T.encodeUtf8 contents of+ (_, Right gpd) -> pure $ flattenPackageDescription gpd+ _ -> liftIO $ assertFailure "could not parse cabal file to gpd"++ -- | Verify that the given module was added to the desired component.+ -- Note that we do not care whether it was added to exposed-modules or other-modules of that component.+ checkModuleAddedTo :: PackageDescription -> String -> ComponentName -> Session ()+ checkModuleAddedTo pd modName compName = do+ let comp = getComponent pd compName+ compModules = case comp of+ CLib lib -> explicitLibModules lib+ CFLib fLib -> foreignLibModules fLib+ CExe exe -> exeModules exe+ CTest test -> testModules test+ CBench bench -> benchmarkModules bench+ testDescription = modName <> " was added to " <> showComponentName compName+ liftIO $ assertBool testDescription $ fromString modName `elem` compModules++cabalAddDependencyTests :: TestTree+cabalAddDependencyTests = testGroup- "CabalAdd Tests"- [ runHaskellTestCaseSession "Code Actions - Can add hidden package to an executable" ("cabal-add-testdata" </> "cabal-add-exe")+ "Add dependency"+ [ runHaskellTestCaseSession "Add to executable" ("cabal-add-testdata" </> "cabal-add-exe") (generateAddDependencyTestSession "cabal-add-exe.cabal" ("src" </> "Main.hs") "split" [253])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a library" ("cabal-add-testdata" </> "cabal-add-lib")+ , runHaskellTestCaseSession "Add to library" ("cabal-add-testdata" </> "cabal-add-lib") (generateAddDependencyTestSession "cabal-add-lib.cabal" ("src" </> "MyLib.hs") "split" [348])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test" ("cabal-add-testdata" </> "cabal-add-tests")+ , runHaskellTestCaseSession "Add to testsuite" ("cabal-add-testdata" </> "cabal-add-tests") (generateAddDependencyTestSession "cabal-add-tests.cabal" ("test" </> "Main.hs") "split" [478])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test with PackageImports" ("cabal-add-testdata" </> "cabal-add-tests")+ , runHaskellTestCaseSession "Add to testsuite with PackageImports" ("cabal-add-testdata" </> "cabal-add-tests") (generateAddDependencyTestSession "cabal-add-tests.cabal" ("test" </> "MainPackageImports.hs") "split" [731])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a benchmark" ("cabal-add-testdata" </> "cabal-add-bench")+ , runHaskellTestCaseSession "Add to benchmark" ("cabal-add-testdata" </> "cabal-add-bench") (generateAddDependencyTestSession "cabal-add-bench.cabal" ("bench" </> "Main.hs") "split" [403]) - , runHaskellTestCaseSession "Code Actions - Can add hidden package to an executable, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget")+ , runHaskellTestCaseSession "Add to executable, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget") (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("src" </> "Main.hs") "split" [269])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a library, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget")+ , runHaskellTestCaseSession "Add to library, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget") (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("lib" </> "MyLib.hs") "split" [413])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to an internal library, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget")+ , runHaskellTestCaseSession "Add to internal library, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget") (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("lib" </> "InternalLib.hs") "split" [413])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget")+ , runHaskellTestCaseSession "Add to testsuite, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget") (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("test" </> "Main.hs") "split" [655])- , runHaskellTestCaseSession "Code Actions - Can add hidden package to a benchmark, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget")+ , runHaskellTestCaseSession "Add to benchmark, multiple targets" ("cabal-add-testdata" </> "cabal-add-multitarget") (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("bench" </> "Main.hs") "split" [776]) - , runHaskellTestCaseSession "Code Actions - Guard against HPack" ("cabal-add-testdata" </> "cabal-add-packageYaml")+ , runHaskellTestCaseSession "Guard against HPack" ("cabal-add-testdata" </> "cabal-add-packageYaml") (generatePackageYAMLTestSession ("src" </> "Main.hs")) , testHiddenPackageSuggestions "Check CabalAdd's parser, no version"@@ -156,7 +212,7 @@ liftIO $ assertEqual (T.unpack dependency <> " isn't found in the cabal file") indicesRes (T.indices dependency contents) testHiddenPackageSuggestions :: String -> [T.Text] -> [(T.Text, T.Text)] -> TestTree testHiddenPackageSuggestions testTitle messages suggestions =- let diags = map (\msg -> messageToDiagnostic msg ) messages+ let diags = map (\msg -> messageToDiagnostic msg) messages suggestions' = map (safeHead . hiddenPackageSuggestion) diags assertions = zipWith (@?=) suggestions' (map Just suggestions) testNames = map (\(f, s) -> "Check if " ++ T.unpack f ++ (if s == "" then "" else "-") ++ T.unpack s ++ " was parsed correctly") suggestions@@ -164,20 +220,19 @@ in test messageToDiagnostic :: T.Text -> Diagnostic messageToDiagnostic msg = Diagnostic {- _range = mkRange 0 0 0 0- , _severity = Nothing- , _code = Nothing- , _source = Nothing- , _message = msg- , _relatedInformation = Nothing- , _tags = Nothing- , _codeDescription = Nothing- , _data_ = Nothing+ J._range = mkRange 0 0 0 0+ , J._severity = Nothing+ , J._code = Nothing+ , J._source = Nothing+ , J._message = msg+ , J._relatedInformation = Nothing+ , J._tags = Nothing+ , J._codeDescription = Nothing+ , J._data_ = Nothing } - generatePackageYAMLTestSession :: FilePath -> Session ()- generatePackageYAMLTestSession haskellFile = do+ generatePackageYAMLTestSession haskellFile = do hsdoc <- openDoc haskellFile "haskell" _ <- waitForDiagnosticsFrom hsdoc cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions hsdoc
plugins/hls-cabal-plugin/test/Completer.hs view
@@ -392,39 +392,39 @@ _ -> error "" importTestData :: T.Text-importTestData = [trimming|-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+importTestData = [__i|+ 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 -common defaults- default-language: GHC2021- -- Should have been in GHC2021, an oversight- default-extensions: ExplicitNamespaces+ 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+ common test-defaults+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -library- import:- ^- exposed-modules: IDE.Plugin.Cabal- build-depends: base ^>=4.14.3.0- hs-source-dirs: src- default-language: Haskell2010+ library+ import:+ ^+ exposed-modules: IDE.Plugin.Cabal+ build-depends: base ^>=4.14.3.0+ hs-source-dirs: src+ default-language: Haskell2010 -common notForLib- default-language: GHC2021+ common notForLib+ default-language: GHC2021 -test-suite tests- import:- ^+ test-suite tests+ import:+ ^ |]
plugins/hls-cabal-plugin/test/Context.hs view
@@ -217,93 +217,93 @@ -- ------------------------------------------------------------------------ libraryStanzaData :: T.Text-libraryStanzaData = [trimming|-cabal-version: 3.0-name: simple-cabal-library- default-language: Haskell98- build-depends:+libraryStanzaData = [__i|+ cabal-version: 3.0+ name: simple-cabal+ library+ default-language: Haskell98+ build-depends: -ma+ ma |] executableStanzaData :: T.Text-executableStanzaData = [trimming|-cabal-version: 3.0-name: simple-cabal-executable exeName- default-language: Haskell2010- hs-source-dirs: test/preprocessor+executableStanzaData = [__i|+ cabal-version: 3.0+ name: simple-cabal+ executable exeName+ default-language: Haskell2010+ hs-source-dirs: test/preprocessor |] topLevelData :: T.Text-topLevelData = [trimming|-cabal-version: 3.0-name:+topLevelData = [__i|+ cabal-version: 3.0+ name: - eee+ eee |] conditionalData :: T.Text-conditionalData = [trimming|-cabal-version: 3.0-name: simple-cabal-library- if os(windows)- buildable:- elif os(linux)- buildable:- else- buildable:+conditionalData = [__i|+ cabal-version: 3.0+ name: simple-cabal+ library+ if os(windows)+ buildable:+ elif os(linux)+ buildable:+ else+ buildable: |] multiLineOptsData :: T.Text-multiLineOptsData = [trimming|-cabal-version: 3.0-name:+multiLineOptsData = [__i|+ cabal-version: 3.0+ name: -library- build-depends:- base,+ library+ build-depends:+ base, - text ,+ text , |] multiPositionTestData :: T.Text-multiPositionTestData = [trimming|-cabal-version: 3.4- ^ ^-category: Development-^-name: haskell-language-server-description:- Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>- ^-extra-source-files:- README.md- ChangeLog.md- test/testdata/**/*.project- test/testdata/**/*.cabal- test/testdata/**/*.yaml- test/testdata/**/*.hs- test/testdata/**/*.json+multiPositionTestData = [__i|+ cabal-version: 3.4+ ^ ^+ category: Development ^- -- These globs should only match test/testdata- plugins/**/*.project+ name: haskell-language-server+ description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server\#readme>+ ^+ 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 -source-repository head- ^ ^ ^- type: git- ^ ^ ^ ^- location: https://github.com/haskell/haskell-language-server+ source-repository head+ ^ ^ ^+ type: git+ ^ ^ ^ ^+ location: https://github.com/haskell/haskell-language-server - ^-common cabalfmt+ ^+ common cabalfmt - ^- build-depends: haskell-language-server:hls-cabal-fmt-plugin- ^ ^- cpp-options: -Dhls_cabalfmt+ ^+ build-depends: haskell-language-server:hls-cabal-fmt-plugin+ ^ ^+ cpp-options: -Dhls_cabalfmt |]
plugins/hls-cabal-plugin/test/Main.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module Main ( main, ) where -import CabalAdd (cabalAddTests)+import CabalAdd (cabalAddDependencyTests,+ cabalAddModuleTests) import Completer (completerTests) import Context (contextTests) import Control.Lens ((^.))@@ -16,14 +19,19 @@ import Data.Either (isRight) import Data.List.Extra (nubOrdOn) import qualified Data.Maybe as Maybe+import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.IO as Text import Definition (gotoDefinitionTests)+import Development.IDE.Test import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib import qualified Language.LSP.Protocol.Lens as L+import qualified Language.LSP.Protocol.Message as L import Outline (outlineTests) import System.FilePath import Test.Hls+import Test.Hls.FileSystem import Utils main :: IO ()@@ -39,6 +47,7 @@ , codeActionTests , gotoDefinitionTests , hoverTests+ , reloadOnCabalChangeTests ] -- ------------------------------------------------------------------------@@ -58,7 +67,8 @@ testGroup "Parsing Cabal" [ testCase "Simple Parsing works" $ do- (warnings, pm) <- Lib.parseCabalFileContents =<< BS.readFile (testDataDir </> "simple.cabal")+ fileContents <- BS.readFile (testDataDir </> "simple.cabal")+ let (warnings, pm) = Lib.parseCabalFileContents fileContents liftIO $ do null warnings @? "Found unexpected warnings" isRight pm @? "Failed to parse GenericPackageDescription"@@ -89,7 +99,7 @@ maxCompletions = 100 --- ------------------------ ------------------------------------------------+-- ------------------------------------------------------------------------ -- Integration Tests -- ------------------------------------------------------------------------ @@ -126,11 +136,6 @@ _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" newDiags <- cabalCaptureKick 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" ] ] -- ----------------------------------------------------------------------------@@ -208,7 +213,8 @@ ]) cas mapM_ executeCodeAction selectedCas pure ()- , cabalAddTests+ , cabalAddDependencyTests+ , cabalAddModuleTests ] where getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction]@@ -259,3 +265,63 @@ h <- getHover doc pos liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h closeDoc doc++-- ----------------------------------------------------------------------------+-- Reloading of Haskell files on .cabal changes+-- ----------------------------------------------------------------------------++simpleCabalVft :: [FileTree]+simpleCabalVft =+ [ copy "hie.yaml"+ , copy "simple-reload.cabal"+ , copy "Main.hs"+ ]++simpleCabalFs :: VirtualFileTree+simpleCabalFs = mkVirtualFileTree+ (testDataDir </> "simple-reload")+ simpleCabalVft++-- Slow tests+reloadOnCabalChangeTests :: TestTree+reloadOnCabalChangeTests = testGroup "Reload on .cabal changes"+ [ runCabalTestCaseSessionVft "Change warnings when .cabal file changes" simpleCabalFs $ do+ _ <- openDoc "Main.hs" "haskell"+ expectDiagnostics [("Main.hs", [(DiagnosticSeverity_Warning, (8, 0), "Top-level binding with no type signature", Just "GHC-38417")])]+ waitForAllProgressDone+ cabalDoc <- openDoc "simple-reload.cabal" "cabal"+ skipManyTill anyMessage cabalKickDone+ saveDoc cabalDoc+ [__i|+ cabal-version: 3.4+ name: simple-reload+ version: 0.1.0.0+ -- copyright:+ build-type: Simple++ common warnings+ ghc-options: -Wall -Wno-missing-signatures++ executable simple-reload+ import: warnings+ main-is: Main.hs+ build-depends: base+ default-language: Haskell2010+ |]++ expectDiagnostics [("Main.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of \8216Data.List\8217 is redundant", Nothing)])]+ ]++-- | Persists the given contents to the 'TextDocumentIdentifier' on disk+-- and sends the @textDocument/didSave@ notification.+saveDoc :: TextDocumentIdentifier -> Text -> Session ()+saveDoc docId t = do+ -- I couldn't figure out how to get the virtual file contents, so we write it+ -- to disk and send the 'SMethod_TextDocumentDidSave' notification+ case uriToFilePath (docId ^. L.uri) of+ Nothing -> pure ()+ Just fp -> do+ liftIO $ Text.writeFile fp t++ let params = DidSaveTextDocumentParams docId Nothing+ sendNotification L.SMethod_TextDocumentDidSave params
plugins/hls-cabal-plugin/test/Utils.hs view
@@ -14,6 +14,7 @@ import Ide.Plugin.Cabal.Completion.Types import System.FilePath import Test.Hls+import Test.Hls.FileSystem (VirtualFileTree) cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log@@ -57,6 +58,13 @@ runCabalSession subdir = failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir </> subdir) +runCabalTestCaseSessionVft :: TestName -> VirtualFileTree -> Session () -> TestTree+runCabalTestCaseSessionVft title vft = testCase title . runCabalSessionVft vft++runCabalSessionVft :: VirtualFileTree -> Session a -> IO a+runCabalSessionVft vft =+ failIfSessionTimeout . runSessionWithServerInTmpDir def cabalPlugin vft+ runHaskellAndCabalSession :: FilePath -> Session a -> IO a runHaskellAndCabalSession subdir = failIfSessionTimeout . runSessionWithServer def (cabalPlugin <> cabalHaskellPlugin) (testDataDir </> subdir)@@ -82,3 +90,4 @@ -- | 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/cabal-add-module/library/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = undefined
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+ cabal:
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-module/library/test.cabal view
@@ -0,0 +1,26 @@+cabal-version: 3.0+name: test+version: 0.1.0.0+build-type: Simple++library+ hs-source-dirs: .+ exposed-modules:+ build-depends: base+ default-language: Haskell2010++executable test+ main-is: bla+ build-depends: base++benchmark test1+ type: exitcode-stdio-1.0+ main-is: bla+ build-depends: base++test-suite test2+ type: exitcode-stdio-1.0+ main-is: bla+ build-depends: base++library test3
+ plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Data.List -- Intentionally unused import, used in the testcase++main :: IO ()+main = foo++-- Missing signature+foo = putStrLn "Hello, World"
+ plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+ cabal:
+ plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal view
@@ -0,0 +1,14 @@+cabal-version: 3.4+name: simple-reload+version: 0.1.0.0+-- copyright:+build-type: Simple++common warnings+ ghc-options: -Wall -Wno-unused-imports++executable simple-reload+ import: warnings+ main-is: Main.hs+ build-depends: base+ default-language: Haskell2010
plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs view
@@ -24,6 +24,12 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint+import GHC.Iface.Ext.Types (ContextInfo (..),+ DeclType (..), HieAST (..),+ HieASTs (..), Identifier,+ IdentifierDetails (..),+ RecFieldContext (..), Span)+import GHC.Iface.Ext.Utils (getNameBinding) import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types
plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs view
@@ -1,48 +1,94 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -- | An HLS plugin to provide code actions to change type signatures module Ide.Plugin.ChangeTypeSignature (descriptor -- * For Unit Tests+ , Log(..) , 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 Control.Lens+import Control.Monad (guard)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Except (ExceptT (..))+import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)+import Data.Foldable (asum)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Development.IDE (FileDiagnostic,+ IdeState (..), Pretty (..),+ Priority (..), Recorder,+ WithPriority,+ fdLspDiagnosticL,+ fdStructuredMessageL,+ logWith, 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 Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))+import Development.IDE.GHC.Compat hiding (vcat)+import Development.IDE.GHC.Compat.Error (_MismatchMessage,+ _TcRnMessageWithCtx,+ _TcRnMessageWithInfo,+ _TcRnSolverReport,+ _TypeEqMismatchActual,+ _TypeEqMismatchExpected,+ msgEnvelopeErrorL,+ reportContentL)+import Development.IDE.GHC.Util (printOutputable)+import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)+import Generics.SYB (extQ, something)+import GHC.Tc.Errors.Types (ErrInfo (..),+ TcRnMessageDetailed (..))+import qualified Ide.Logger as Logger+import Ide.Plugin.Error (PluginError,+ getNormalizedFilePathE)+import Ide.Types (Config, HandlerM,+ PluginDescriptor (..),+ PluginId (PluginId),+ PluginMethodHandler,+ defaultPluginDescriptor,+ mkPluginHandler) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Text.Regex.TDFA ((=~))+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) }+data Log+ = LogErrInfoCtxt ErrInfo+ | LogFindSigLocFailure DeclName -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+instance Pretty Log where+ pretty = \case+ LogErrInfoCtxt (ErrInfo ctxt suppl) ->+ Logger.vcat [fromSDoc ctxt, fromSDoc suppl]+ LogFindSigLocFailure name ->+ pretty ("Lookup signature location failure: " <> name)+ where+ fromSDoc = pretty . printOutputable +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId =+ (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")+ { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler recorder plId)+ }++codeActionHandler+ :: Recorder (WithPriority Log)+ -> PluginId+ -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+codeActionHandler recorder plId ideState _ CodeActionParams{_textDocument, _range} = do+ let TextDocumentIdentifier uri = _textDocument+ nfp <- getNormalizedFilePathE uri+ decls <- getDecls plId ideState nfp++ activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case+ Nothing -> pure (InL [])+ Just fileDiags -> do+ actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags+ pure (InL (catMaybes actions))+ getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = runActionE (T.unpack changeTypeSignatureId <> ".GetParsedModule") state@@ -67,39 +113,74 @@ -- | the location of the declaration signature , declSrcSpan :: RealSrcSpan -- | the diagnostic to solve- , diagnostic :: Diagnostic+ , diagnostic :: FileDiagnostic } -- | 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+generateAction+ :: Recorder (WithPriority Log)+ -> PluginId+ -> Uri+ -> [LHsDecl GhcPs]+ -> FileDiagnostic+ -> HandlerM Config (Maybe (Command |? CodeAction))+generateAction recorder plId uri decls fileDiag = do+ changeSig <- diagnosticToChangeSig recorder decls fileDiag+ pure $+ changeSigToCodeAction plId uri <$> changeSig -- | 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{..}+diagnosticToChangeSig+ :: Recorder (WithPriority Log)+ -> [LHsDecl GhcPs]+ -> FileDiagnostic+ -> HandlerM Config (Maybe ChangeSignature)+diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do+ -- Extract expected, actual, and extra error info+ (expectedType, actualType, errInfo) <- hoistMaybe $ do+ msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage+ tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx+ (_, TcRnMessageDetailed errInfo tcRnMsg') <- tcRnMsg ^? _TcRnMessageWithInfo+ solverReport <- tcRnMsg' ^? _TcRnSolverReport . _1 . reportContentL+ mismatch <- solverReport ^? _MismatchMessage+ expectedType <- mismatch ^? _TypeEqMismatchExpected+ actualType <- mismatch ^? _TypeEqMismatchActual + pure (showType expectedType, showType actualType, errInfo) + logWith recorder Debug (LogErrInfoCtxt errInfo)++ -- Extract the declName from the extra error text+ declName <- hoistMaybe (matchingDiagnostic errInfo)++ -- Look up location of declName. If it fails, log it+ declSrcSpan <-+ case findSigLocOfStringDecl decls expectedType (T.unpack declName) of+ Just x -> pure x+ Nothing -> do+ logWith recorder Debug (LogFindSigLocFailure declName)+ hoistMaybe Nothing++ pure ChangeSignature{..}+ where+ showType :: Type -> Text+ showType = T.pack . showSDocUnsafe . pprTidiedType+ -- | 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+matchingDiagnostic :: ErrInfo -> Maybe DeclName+matchingDiagnostic ErrInfo{errInfoContext} =+ asum $ map (unwrapMatch . (=~) errInfoTxt) 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+ unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe DeclName+ unwrapMatch (_, _, _, [name]) = Just name+ unwrapMatch _ = Nothing + errInfoTxt = printOutputable errInfoContext+ -- | 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 ‘(.+)’"+ "In an equation for ‘(.+)’:" ] -- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches@@ -147,7 +228,7 @@ changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType , _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))- , _diagnostics = Just [diagnostic]+ , _diagnostics = Just [diagnostic ^. fdLspDiagnosticL ] , _isPreferred = Nothing , _disabled = Nothing , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)
plugins/hls-change-type-signature-plugin/test/Main.hs view
@@ -5,7 +5,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes)+import Ide.Plugin.ChangeTypeSignature (Log (..), errorMessageRegexes) import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature import System.FilePath ((<.>), (</>)) import Test.Hls (CodeAction (..), Command,@@ -21,8 +21,7 @@ getCodeActions, goldenWithHaskellDoc, knownBrokenForGhcVersions,- liftIO,- mkPluginTestDescriptor',+ liftIO, mkPluginTestDescriptor, openDoc, runSessionWithServer, testCase, testGroup, toEither, type (|?), waitForBuildQueue,@@ -32,16 +31,19 @@ main :: IO () main = defaultTestRunner test -changeTypeSignaturePlugin :: PluginTestDescriptor ()-changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature"+changeTypeSignaturePlugin :: PluginTestDescriptor Log+changeTypeSignaturePlugin =+ mkPluginTestDescriptor+ ChangeTypeSignature.descriptor+ "changeTypeSignature" test :: TestTree test = testGroup "changeTypeSignature" [ testRegexes , codeActionTest "TExpectedActual" 4 11- , knownBrokenForGhcVersions [GHC94 .. GHC912] "Error Message in 9.2+ does not provide enough info" $+ , knownBrokenForGhcVersions [GHC96 .. GHC912] "Error Message in 9.6+ does not provide enough info" $ codeActionTest "TRigidType" 4 14- , codeActionTest "TRigidType2" 4 6+ , codeActionTest "TRigidType2" 4 8 , codeActionTest "TLocalBinding" 7 22 , codeActionTest "TLocalBindingShadow1" 11 8 , codeActionTest "TLocalBindingShadow2" 7 22@@ -50,43 +52,17 @@ 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+ regexTest "TExpectedActual.txt" regex True+ , regexTest "TLocalBinding.txt" regex True+ , regexTest "TLocalBindingShadow1.txt" regex True+ , regexTest "TLocalBindingShadow2.txt" regex True+ -- Error message from GHC currently does not not provide enough info+ , regexTest "TRigidType.txt" regex False+ , regexTest "TRigidType2.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" @@ -123,8 +99,8 @@ 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) -> pure ()+ ((_, _, _, [_]), False) -> assertFailure $ "Unexpected match: " <> fp <> " with " <> T.unpack regex (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex (_, False) -> pure ()
+ plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt view
@@ -0,0 +1,8 @@+In the expression: go+In an equation for ‘fullSig’:+fullSig+ = go+ where+ go = head . reverse++
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.txt view
@@ -0,0 +1,8 @@+Probable cause: ‘forM’ is applied to too few arguments+In the expression: forM+In an equation for ‘test’: test = forM+In the expression:+ let+ test :: Int -> Int+ test = forM+ in x + 1
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.txt view
@@ -0,0 +1,4 @@+Probable cause: ‘forM’ is applied to too few arguments+In the expression: forM+In an equation for ‘test’: test = forM+
+ plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.txt view
@@ -0,0 +1,9 @@+Probable cause: ‘forM’ is applied to too few arguments+In the expression: forM+In an equation for ‘test’: test = forM+In the expression:+ let+ test :: Int -> Int+ test = forM+ in test x [GHC-83865]+
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt view
@@ -0,0 +1,5 @@+In the expression: go . head . reverse+Relevant bindings include+ test :: a -> Int+ (bound at /home/sgillespie/dev/haskell/haskell-language-server/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs:4:1) [GHC-25897]+
+ plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt view
@@ -0,0 +1,6 @@+In the expression: head+In an equation for ‘test’: test = head+Relevant bindings include+ test :: a -> Int+ (bound at /home/sgillespie/dev/haskell/haskell-language-server/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs:4:1) [GHC-25897]+
− plugins/hls-change-type-signature-plugin/test/testdata/error1.txt
@@ -1,6 +0,0 @@- • 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
@@ -1,6 +0,0 @@- • 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
@@ -1,10 +0,0 @@- • 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
@@ -1,19 +0,0 @@- • 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
@@ -1,15 +0,0 @@- • 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-class-plugin/src/Ide/Plugin/Class/CodeAction.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Class.CodeAction where+module Ide.Plugin.Class.CodeAction (+ addMethodPlaceholders,+ codeAction,+) where +import Control.Arrow ((>>>)) import Control.Lens hiding (List, use) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Extra@@ -13,8 +18,6 @@ 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@@ -23,13 +26,19 @@ 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.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Error (TcRnMessage (..),+ _TcRnMessage,+ msgEnvelopeErrorL,+ stripTcRnMessageContext) import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.AtPoint (pointCommand)+import GHC.Iface.Ext.Types (ContextInfo (..),+ HieAST (..), Identifier,+ IdentifierDetails (..)) import Ide.Plugin.Class.ExactPrint import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils@@ -80,23 +89,25 @@ -- 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+codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)- actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags- pure $ InL actions+ activeDiagnosticsInRange (shakeExtras state) nfp caRange+ >>= \case+ Nothing -> pure $ InL []+ Just fileDiags -> do+ actions <- join <$> mapM (mkActions nfp verTxtDocId) (methodDiags fileDiags)+ 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+ methodDiags fileDiags =+ mapMaybe (\d -> (d,) <$> isClassMethodWarning (d ^. fdStructuredMessageL)) fileDiags mkActions :: NormalizedFilePath -> VersionedTextDocumentIdentifier- -> Diagnostic+ -> (FileDiagnostic, ClassMinimalDef) -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]- mkActions docPath verTxtDocId diag = do+ mkActions docPath verTxtDocId (diag, classMinDef) = do (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state $ useWithStaleE GetHieAst docPath instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $@@ -108,21 +119,19 @@ $ 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)+ logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) cls classMinDef) pure $ concatMap mkAction $ nubOrdOn snd $ filter ((/=) mempty . snd)- $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))- $ mkMethodGroups hsc gblEnv range sigs cls+ $ mkMethodGroups hsc gblEnv range sigs classMinDef where- range = diag ^. L.range+ range = diag ^. fdLspDiagnosticL . L.range - mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]- mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]+ mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]+ mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods] where- minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls+ minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs) mkAction :: MethodGroup -> [Command |? CodeAction]@@ -163,25 +172,6 @@ <=< nodeChildren ) - findImplementedMethods- :: HieASTs a- -> Position- -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [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@@ -203,12 +193,15 @@ 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"+isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef+isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of+ Nothing -> Nothing+ Just tcRnMessage -> isUnsatisfiedMinimalDefWarning tcRnMessage -isInstanceValBind :: ContextInfo -> Bool-isInstanceValBind (ValBind InstanceBind _ _) = True-isInstanceValBind _ = False+isUnsatisfiedMinimalDefWarning :: TcRnMessage -> Maybe ClassMinimalDef+isUnsatisfiedMinimalDefWarning = stripTcRnMessageContext >>> \case+ TcRnUnsatisfiedMinimalDef classMinDef -> Just classMinDef+ _ -> Nothing type MethodSignature = T.Text type MethodName = T.Text
plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs view
@@ -46,10 +46,8 @@ #if MIN_VERSION_ghc_exactprint(1,10,0) addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> Located (HsModule GhcPs)-#elif 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)+addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located (HsModule GhcPs)) #endif addMethodDecls ps mDecls range withSig | withSig = go (concatMap (\(decl, sig) -> [sig, decl]) mDecls)
plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs view
@@ -112,15 +112,15 @@ type instance RuleResult GetInstanceBindLens = InstanceBindLensResult data Log- = LogImplementedMethods Class [T.Text]+ = LogImplementedMethods DynFlags Class ClassMinimalDef | LogShake Shake.Log instance Pretty Log where pretty = \case- LogImplementedMethods cls methods ->- pretty ("Detected implemented methods for class" :: String)+ LogImplementedMethods dflags cls methods ->+ pretty ("The following methods are missing" :: String) <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name- <+> pretty methods+ <+> pretty (showSDoc dflags $ ppr methods) LogShake log -> pretty log data BindInfo = BindInfo
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs view
@@ -19,7 +19,11 @@ 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 Development.IDE.GHC.Compat+import GHC.Iface.Ext.Types (ContextInfo (..), HieAST (..),+ Identifier, IdentifierDetails (..),+ NodeInfo (nodeIdentifiers), Span)+import GHC.Iface.Ext.Utils (RefMap, flattenAst) import Prelude hiding (span) {-|
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs view
@@ -39,18 +39,17 @@ 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 GHC.Iface.Ext.Types (HieAST (..), HieASTs (..))+import GHC.Iface.Ext.Utils (RefMap) 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 Language.LSP.Protocol.Types (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region)) import Prelude hiding (log) data Log = LogShake Shake.Log
plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs view
@@ -27,7 +27,7 @@ -- |Plugin descriptor descriptor :: Recorder (WithPriority Eval.Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId =- (defaultPluginDescriptor plId "Provies code action and lens to evaluate expressions in doctest comments")+ (defaultPluginDescriptor plId "Provides code action and lens to evaluate expressions in doctest comments") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeAction (Handlers.codeAction recorder) , mkPluginHandler SMethod_TextDocumentCodeLens (Handlers.codeLens recorder)
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs view
@@ -41,14 +41,10 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope-import Development.IDE.Core.FileStore (getUriContents)+import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) import Development.IDE.Core.Rules (IdeState, runAction)-import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod),- TypeCheck (..),- tmrTypechecked)-import Development.IDE.Core.Shake (useNoFile_, use_,- uses_)+import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import Development.IDE.GHC.Compat.Util (OverridingBool (..))@@ -76,17 +72,18 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetLinkable), GetModSummary (GetModSummary),- GetModuleGraph (GetModuleGraph),+ GetModuleGraphTransDepsFingerprints (GetModuleGraphTransDepsFingerprints), GhcSessionDeps (GhcSessionDeps),- ModSummaryResult (msrModSummary))-import Development.IDE.Core.Shake (VFSModified (VFSUnmodified))+ ModSummaryResult (msrModSummary),+ LinkableResult (linkableHomeMod),+ TypeCheck (..),+ tmrTypechecked, GetModuleGraphTransDepsFingerprints(..), GetModuleGraph(..)) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (unLoc) import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Data.List.Extra (unsnoc)-import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))@@ -256,7 +253,7 @@ ms <- msrModSummary <$> use_ GetModSummary nfp deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp - linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp+ linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph nfp <*> 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]
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs view
@@ -73,11 +73,7 @@ #endif span) c) where-#if MIN_VERSION_ghc(9,5,0) getEpaComments :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment]-#else- getEpaComments :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]-#endif getEpaComments = toListOf biplate pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -77,9 +77,7 @@ $ bagToList $ fmap (vcat . unDecorated . diagnosticMessage-#if MIN_VERSION_ghc(9,5,0) (defaultDiagnosticOpts @GhcMessage)-#endif . errMsgDiagnostic) $ getMessages msgs _ ->
plugins/hls-eval-plugin/test/Main.hs view
@@ -84,8 +84,7 @@ 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"- , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs"- (if ghcVersion >= GHC94 then "ghc94.expected" else "expected")+ , goldenWithEval "Reports an error for an incorrect type with :kind!" "T11" "hs" , goldenWithEval "Shows a kind with :kind" "T12" "hs" , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs" , 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@@ -138,7 +137,6 @@ GHC910 -> "ghc910.expected" GHC98 -> "ghc98.expected" GHC96 -> "ghc96.expected"- GHC94 -> "ghc94.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"@@ -219,7 +217,7 @@ knownBrokenInWindowsBeforeGHC912 msg = foldl (.) id [ knownBrokenInSpecificEnv [GhcVer ghcVer, HostOS Windows] msg- | ghcVer <- [GHC94 .. GHC910]+ | ghcVer <- [GHC96 .. GHC910] ] goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree
− plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs
@@ -1,4 +0,0 @@-module T11 where---- >>> :kind! A--- Not in scope: type constructor or class `A'
plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs view
@@ -10,4 +10,12 @@ -- errorEmptyList, called at libraries/ghc-internal/src/GHC/Internal/List.hs:96:11 in ghc-internal:GHC.Internal.List -- badHead, called at libraries/ghc-internal/src/GHC/Internal/List.hs:90:28 in ghc-internal:GHC.Internal.List -- head, called at <interactive>:1:27 in interactive:Ghci2+-- HasCallStack backtrace:+-- collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception+-- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:204:5 in ghc-internal:GHC.Internal.Exception+-- error, called at libraries/ghc-internal/src/GHC/Internal/List.hs:2030:3 in ghc-internal:GHC.Internal.List+-- errorEmptyList, called at libraries/ghc-internal/src/GHC/Internal/List.hs:96:11 in ghc-internal:GHC.Internal.List+-- badHead, called at libraries/ghc-internal/src/GHC/Internal/List.hs:90:28 in ghc-internal:GHC.Internal.List+-- head, called at <interactive>:1:27 in interactive:Ghci2+-- -- []
plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs view
@@ -472,11 +472,7 @@ 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,@@ -528,11 +524,7 @@ 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@@ -549,22 +541,12 @@ 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)
plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs view
@@ -58,8 +58,7 @@ HsExpr (HsApp, HsVar, XExpr), HsFieldBind (hfbLHS), HsRecFields (..),- HsWrap (HsWrap),- Identifier, LPat,+ HsWrap (HsWrap), LPat, Located, NamedThing (getName), Outputable,@@ -82,13 +81,15 @@ pattern RealSrcSpan, plusUFM_C, unitUFM) import Development.IDE.GHC.Util (getExtensions,- printOutputable)+ printOutputable,+ stripOccNamePrefix) 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 GHC.Iface.Ext.Types (Identifier) import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>))@@ -151,10 +152,17 @@ 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+ CRR {crCodeActions, crCodeActionResolve, 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)+ let recordUids = [ uid+ | uid <- RangeMap.filterByRange range crCodeActions+ , Just record <- [IntMap.lookup uid crCodeActionResolve]+ -- Only fully saturated constructor applications can be+ -- converted to the record syntax through the code action+ , isConvertible record+ ]+ let actions = map (mkCodeAction enabledExtensions) recordUids pure $ InL actions where mkCodeAction :: [Extension] -> Int -> Command |? CodeAction@@ -169,6 +177,11 @@ , _data_ = Just $ toJSON uid } + isConvertible :: RecordInfo -> Bool+ isConvertible = \case+ RecordInfoApp _ (RecordAppExpr Unsaturated _ _) -> False+ _ -> True+ codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve codeActionResolveProvider ideState pId ca uri uid = do nfp <- getNormalizedFilePathE uri@@ -226,7 +239,7 @@ -- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False' nameEq = either (const False) ((==) name) in fmap fst $ find (nameEq . snd) filteredLocations- valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]+ valueWithLoc = [ (stripOccNamePrefix $ T.pack $ printName name, findLocation name defnLocs') | name <- names' ] -- use `, ` to separate labels with definition location label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc pure $ InlayHint { _position = currentEnd -- at the end of dotdot@@ -253,7 +266,7 @@ pure $ InL (concatMap (mkInlayHints nameMap pm) records) where mkInlayHints :: UniqFM Name [Name] -> PositionMapping -> RecordInfo -> [InlayHint]- mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr _ fla)) =+ mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr _ _ fla)) = let textEdits = renderRecordInfoAsTextEdit nameMap record in mapMaybe (mkInlayHint textEdits pm) fla mkInlayHints _ _ _ = []@@ -275,7 +288,7 @@ , _data_ = Nothing } - mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing+ mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing mkTitle :: [Extension] -> Text mkTitle exts = "Expand record wildcard"@@ -379,9 +392,18 @@ type instance RuleResult CollectNames = CollectNamesResult -data RecordAppExpr = RecordAppExpr (LHsExpr GhcTc) [(Located FieldLabel, HsExpr GhcTc)]+data Saturated = Saturated | Unsaturated deriving (Generic) +instance NFData Saturated++data RecordAppExpr+ = RecordAppExpr+ Saturated -- ^ Is the DataCon application fully saturated or partially applied?+ (LHsExpr GhcTc)+ [(Located FieldLabel, HsExpr GhcTc)]+ deriving (Generic)+ data RecordInfo = RecordInfoPat RealSrcSpan (Pat GhcTc) | RecordInfoCon RealSrcSpan (HsExpr GhcTc)@@ -389,10 +411,10 @@ 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)- pretty (RecordInfoApp ss (RecordAppExpr _ fla))- = pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)+ pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)+ pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)+ pretty (RecordInfoApp ss (RecordAppExpr _ _ fla))+ = pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla) recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss@@ -499,7 +521,7 @@ showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text-showRecordPat names = fmap printOutputable . mapConPatDetail (\case+showRecordPat names = fmap printFieldName . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) @@ -536,11 +558,11 @@ showRecordConFlds _ = Nothing showRecordApp :: RecordAppExpr -> Maybe Text-showRecordApp (RecordAppExpr recConstr fla)+showRecordApp (RecordAppExpr _ recConstr fla) = Just $ printOutputable recConstr <> " { " <> T.intercalate ", " (showFieldWithArg <$> fla) <> " }"- where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg+ where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg collectRecords :: GenericQ [RecordInfo] collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)@@ -588,8 +610,14 @@ getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr getFields (HsApp _ constr@(unLoc -> expr) arg) args- | not (null fls)- = Just (RecordAppExpr constr labelWithArgs)+ | not (null fls) = Just $+ -- Code action is only valid if the constructor application is fully+ -- saturated, but we still want to display the inlay hints for partially+ -- applied constructors+ RecordAppExpr+ (if length fls <= length args + 1 then Saturated else Unsaturated)+ constr+ labelWithArgs where fls = getExprFields expr labelWithArgs = zipWith mkLabelWithArg fls (arg : args) mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg)@@ -614,3 +642,7 @@ mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = ([], False)++printFieldName :: Outputable a => a -> Text+printFieldName = stripOccNamePrefix . printOutputable+
plugins/hls-explicit-record-fields-plugin/test/Main.hs view
@@ -36,6 +36,7 @@ , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 , mkTestNoAction "Prefix" "Prefix" 10 11 10 28+ , mkTestNoAction "PartiallyAppliedCon" "PartiallyAppliedCon" 7 8 7 12 , mkTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15 ] , testGroup "inlay hints"@@ -56,6 +57,24 @@ , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }]+ , mkInlayHintsTest "ConstructionDuplicateRecordFields" Nothing 16 $ \ih -> do+ let mkLabelPart' = mkLabelPartOffsetLength "ConstructionDuplicateRecordFields"+ foo <- mkLabelPart' 13 6 "foo"+ bar <- mkLabelPart' 14 6 "bar"+ baz <- mkLabelPart' 15 6 "baz"+ (@?=) ih+ [defInlayHint { _position = Position 16 14+ , _label = InR [ foo, commaPart+ , bar, commaPart+ , baz+ ]+ , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15+ , mkPragmaTextEdit 3 -- Not 2 of the DuplicateRecordFields pragma+ ]+ , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"+ , _paddingLeft = Just True+ }]+ , mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction" foo <- mkLabelPart' 5 4 "foo="@@ -81,6 +100,31 @@ , _paddingLeft = Nothing } ]+ , mkInlayHintsTest "PositionalConstructionDuplicateRecordFields" Nothing 15 $ \ih -> do+ let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstructionDuplicateRecordFields"+ foo <- mkLabelPart' 5 4 "foo="+ bar <- mkLabelPart' 6 4 "bar="+ baz <- mkLabelPart' 7 4 "baz="+ (@?=) ih+ [ defInlayHint { _position = Position 15 11+ , _label = InR [ foo ]+ , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+ , _tooltip = Just $ InL "Expand positional record"+ , _paddingLeft = Nothing+ }+ , defInlayHint { _position = Position 15 13+ , _label = InR [ bar ]+ , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+ , _tooltip = Just $ InL "Expand positional record"+ , _paddingLeft = Nothing+ }+ , defInlayHint { _position = Position 15 15+ , _label = InR [ baz ]+ , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+ , _tooltip = Just $ InL "Expand positional record"+ , _paddingLeft = Nothing+ }+ ] , mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1" foo <- mkLabelPart' 11 4 "foo"@@ -93,6 +137,16 @@ }] , mkInlayHintsTest "HsExpanded1" (Just " (positional)") 13 $ \ih -> do let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1"+ foo <- mkLabelPart' 11 4 "foo="+ (@?=) ih+ [defInlayHint { _position = Position 13 21+ , _label = InR [ foo ]+ , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]+ , _tooltip = Just $ InL "Expand positional record"+ , _paddingLeft = Nothing+ }]+ , mkInlayHintsTest "HsExpanded1DuplicateRecordFields" (Just " (positional)") 13 $ \ih -> do+ let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1DuplicateRecordFields" foo <- mkLabelPart' 11 4 "foo=" (@?=) ih [defInlayHint { _position = Position 13 21
+ plugins/hls-explicit-record-fields-plugin/test/testdata/ConstructionDuplicateRecordFields.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+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/HsExpanded1DuplicateRecordFields.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DuplicateRecordFields #-}+module HsExpanded1DuplicateRecordFields 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/PositionalConstructionDuplicateRecordFields.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE DuplicateRecordFields #-}+module PositionalConstruction where++data MyRec = MyRec+ { foo :: Int+ , bar :: Int+ , baz :: Char+ }++convertMe :: () -> MyRec+convertMe _ =+ let a = 3+ b = 5+ c = 'a'+ in MyRec a b c+
+ plugins/hls-explicit-record-fields-plugin/test/testdata/noop/PartiallyAppliedCon.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE Haskell2010 #-}++module PartiallyAppliedCon where++data T = MkT { fa :: Int, fb :: Char }++foo :: Int -> Char -> T+foo x = MkT x
plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs view
@@ -26,18 +26,13 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0) import qualified Data.List.NonEmpty as NE-#endif -#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0)-import GHC.Parser.Annotation (TokenLocation (..))-#endif- #if !MIN_VERSION_ghc(9,9,0) import GHC.Parser.Annotation (Anchor (Anchor), AnchorOperation (MovedAnchor), SrcSpanAnn' (SrcSpanAnn),+ TokenLocation (..), spanAsAnchor) #endif @@ -106,6 +101,7 @@ h98ToGADTConDecl dataName tyVars ctxt = \case ConDeclH98{..} -> ConDeclGADT+ #if MIN_VERSION_ghc(9,11,0) (AnnConDeclGADT [] [] NoEpUniTok) #elif MIN_VERSION_ghc(9,9,0)@@ -113,13 +109,10 @@ #else con_ext #endif-#if MIN_VERSION_ghc(9,5,0)+ (NE.singleton con_name)-#else- [con_name]-#endif -#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0)+#if !MIN_VERSION_ghc(9,9,0) (L NoTokenLoc HsNormalTok) #endif -- Ignore all existential type variable since GADT not needed
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-}@@ -54,15 +53,20 @@ import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics)++#if APPLY_REFACT import qualified Refact.Apply as Refact import qualified Refact.Types as Refact+#if !MIN_VERSION_apply_refact(0,12,0)+import System.Environment (setEnv,+ unsetEnv)+#endif+#endif import Development.IDE.GHC.Compat (DynFlags,- WarningFlag (Opt_WarnUnrecognisedPragmas), extensionFlags, ms_hspp_opts,- topDir,- wopt)+ topDir) import qualified Development.IDE.GHC.Compat.Util as EnumSet #if MIN_GHC_API_VERSION(9,4,0)@@ -105,6 +109,7 @@ (Null) import qualified Language.LSP.Protocol.Types as LSP +import Development.IDE.Core.PluginUtils as PluginUtils import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), NextPragmaInfo (NextPragmaInfo),@@ -114,11 +119,6 @@ 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 () -- ---------------------------------------------------------------------@@ -126,7 +126,9 @@ data Log = LogShake Shake.Log | LogApplying NormalizedFilePath (Either String WorkspaceEdit)+#if APPLY_REFACT | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]]+#endif | LogGetIdeas NormalizedFilePath | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them | forall a. (Pretty a) => LogResolve a@@ -135,7 +137,9 @@ pretty = \case LogShake log -> pretty log LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res+#if APPLY_REFACT LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas+#endif LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts) LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp LogResolve msg -> pretty msg@@ -413,12 +417,19 @@ edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle pure $ ca & LSP.edit ?~ edit +applyRefactAvailable :: Bool+#if APPLY_REFACT+applyRefactAvailable = True+#else+applyRefactAvailable = False+#endif+ -- | 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 isHintApplicable = "refact:" `T.isPrefixOf` code && applyRefactAvailable , let hint = T.replace "refact:" "" code , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" , let suppressHintArguments = IgnoreHint verTxtDocId hint@@ -453,19 +464,10 @@ 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+ textEdit = LSP.TextEdit nextPragmaRange $ "{- HLINT ignore \"" <> hint <> "\" -}\n" lineSplitTextEditList = maybe [] (\LineSplitTextEdits{..} -> [lineSplitInsertTextEdit, lineSplitDeleteTextEdit]) lineSplitTextEdits in- combinedTextEdit : lineSplitTextEditList+ textEdit : lineSplitTextEditList -- --------------------------------------------------------------------- ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)@@ -506,6 +508,11 @@ } deriving (Generic, Eq, Show, ToJSON, FromJSON) applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)+#if !APPLY_REFACT+applyHint _ _ _ _ _ =+ -- https://github.com/ndmitchell/hlint/pull/1594#issuecomment-2338898673+ evaluate $ error "Cannot apply refactoring: apply-refact does not work on GHC 9.10"+#else applyHint recorder ide nfp mhint verTxtDocId = runExceptT $ do let runAction' :: Action a -> IO a@@ -607,7 +614,7 @@ -- with the @LANGUAGE@ pragmas, pragmas win. [String] -> IO String-applyRefactorings =+applyRefactorings = #if MIN_VERSION_apply_refact(0,12,0) Refact.applyRefactorings #else@@ -623,4 +630,5 @@ withRuntimeLibdir :: FilePath -> IO a -> IO a withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key) where key = "GHC_EXACTPRINT_GHC_LIBDIR"+#endif #endif
plugins/hls-hlint-plugin/test/Main.hs view
@@ -45,12 +45,12 @@ getApplyHintText name = "Apply hint \"" <> name <> "\"" resolveTests :: TestTree-resolveTests = testGroup "hlint resolve tests"+resolveTests = knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ 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)+ "Resolve version of: Ignore hint in this module inserts hlint ignore pragma"+ "IgnoreHintAction"+ (Point 2 8) "Eta reduce" , applyHintGoldenResolveTest "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left"@@ -64,19 +64,14 @@ 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)+ "Ignore hint in this module inserts hlint ignore pragma"+ "IgnoreHintAction"+ (Point 2 8) "Eta reduce" ] applyHintTests :: TestTree-applyHintTests = testGroup "hlint apply hint tests"+applyHintTests = knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ testGroup "hlint apply hint tests" [ applyHintGoldenTest "[#2612] Apply hint works when operator fixities go right-to-left"@@ -88,7 +83,7 @@ suggestionsTests :: TestTree suggestionsTests = testGroup "hlint suggestions" [- testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do+ knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" diags@(reduceDiag:_) <- hlintCaptureKick @@ -120,7 +115,7 @@ contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ testCase "falls back to pre 3.8 code actions" $ runSessionWithTestConfig def { testConfigCaps = noLiteralCaps , testDirLocation = Left testDir@@ -179,15 +174,15 @@ doc <- openDoc "CppHeader.hs" "haskell" testHlintDiagnostics doc - , testCase "[#590] apply-refact works with -XLambdaCase argument" $ runHlintSession "lambdacase" $ do+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ 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+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ 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+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do testRefactor "LambdaCase.hs" "Redundant bracket" ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) @@ -213,10 +208,10 @@ doc <- openDoc "IgnoreAnnHlint.hs" "haskell" testNoHlintDiagnostics doc - , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ 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+ , knownBrokenForGhcVersions [GHC910] "apply-refact doesn't work on 9.10" $ 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
+ plugins/hls-hlint-plugin/test/testdata/IgnoreHintAction.expected.hs view
@@ -0,0 +1,3 @@+{- HLINT ignore "Eta reduce" -}+module IgnoreHintAction where+foo x = id x
+ plugins/hls-hlint-plugin/test/testdata/IgnoreHintAction.hs view
@@ -0,0 +1,2 @@+module IgnoreHintAction where+foo x = id x
− plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs
@@ -1,4 +0,0 @@-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Eta reduce" #-}-module UnrecognizedPragmasOff where-foo x = id x
− plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs
@@ -1,3 +0,0 @@-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-module UnrecognizedPragmasOff where-foo x = id x
− plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs
@@ -1,5 +0,0 @@-{-# 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
@@ -1,3 +0,0 @@-{-# OPTIONS_GHC -Wunrecognised-pragmas #-}-module UnrecognizedPragmasOn where-foo x = id x
plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs view
@@ -1,17 +1,21 @@ module Ide.Plugin.Notes (descriptor, Log) where import Control.Lens ((^.))-import Control.Monad.Except (throwError)+import Control.Monad.Except (ExceptT, MonadError,+ throwError) import Control.Monad.IO.Class (liftIO) import qualified Data.Array as A+import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS+import Data.List (uncons) import Data.Maybe (catMaybes, listToMaybe, mapMaybe) import Data.Text (Text, intercalate) import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope+import Data.Traversable (for) import Development.IDE hiding (line) import Development.IDE.Core.PluginUtils (runActionE, useE) import Development.IDE.Core.Shake (toKnownFiles)@@ -21,8 +25,8 @@ import Ide.Plugin.Error (PluginError (..)) import Ide.Types import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition),- SMethod (SMethod_TextDocumentDefinition))+import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition, Method_TextDocumentReferences),+ SMethod (SMethod_TextDocumentDefinition, SMethod_TextDocumentReferences)) import Language.LSP.Protocol.Types import Text.Regex.TDFA (Regex, caseSensitive, defaultCompOpt,@@ -31,25 +35,39 @@ data Log = LogShake Shake.Log- | LogNotesFound NormalizedFilePath [(Text, Position)]+ | LogNotesFound NormalizedFilePath [(Text, [Position])]+ | LogNoteReferencesFound NormalizedFilePath [(Text, [Position])] deriving Show data GetNotesInFile = MkGetNotesInFile deriving (Show, Generic, Eq, Ord) deriving anyclass (Hashable, NFData)-type instance RuleResult GetNotesInFile = HM.HashMap Text Position+-- The GetNotesInFile action scans the source file and extracts a map of note+-- definitions (note name -> position) and a map of note references+-- (note name -> [position]).+type instance RuleResult GetNotesInFile = (HM.HashMap Text Position, HM.HashMap Text [Position]) data GetNotes = MkGetNotes deriving (Show, Generic, Eq, Ord) deriving anyclass (Hashable, NFData)+-- GetNotes collects all note definition across all files in the+-- project. It returns a map from note name to pair of (filepath, position). type instance RuleResult GetNotes = HashMap Text (NormalizedFilePath, Position) +data GetNoteReferences = MkGetNoteReferences+ deriving (Show, Generic, Eq, Ord)+ deriving anyclass (Hashable, NFData)+-- GetNoteReferences collects all note references across all files in the+-- project. It returns a map from note name to list of (filepath, position).+type instance RuleResult GetNoteReferences = HashMap Text [(NormalizedFilePath, Position)]+ instance Pretty Log where pretty = \case- LogShake l -> pretty l- LogNotesFound file notes ->- "Found notes in " <> pretty (show file) <> ": ["- <> pretty (intercalate ", " (fmap (\(s, p) -> "\"" <> s <> "\" at " <> T.pack (show p)) notes)) <> "]"+ LogShake l -> pretty l+ LogNoteReferencesFound file refs -> "Found note references in " <> prettyNotes file refs+ LogNotesFound file notes -> "Found notes in " <> prettyNotes file notes+ where prettyNotes file hm = pretty (show file) <> ": ["+ <> pretty (intercalate ", " (fmap (\(s, p) -> "\"" <> s <> "\" at " <> intercalate ", " (map (T.pack . show) p)) hm)) <> "]" {- The first time the user requests a jump-to-definition on a note reference, the@@ -59,7 +77,9 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides goto definition support for GHC-style notes") { Ide.Types.pluginRules = findNotesRules recorder- , Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentDefinition jumpToNote+ , Ide.Types.pluginHandlers =+ mkPluginHandler SMethod_TextDocumentDefinition jumpToNote+ <> mkPluginHandler SMethod_TextDocumentReferences listReferences } findNotesRules :: Recorder (WithPriority Log) -> Rules ()@@ -69,20 +89,59 @@ defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotes _ -> do targets <- toKnownFiles <$> useNoFile_ GetKnownTargets- definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (nfp,)) <$> use MkGetNotesInFile nfp) (HS.toList targets)+ definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (nfp,) . fst) <$> use MkGetNotesInFile nfp) (HS.toList targets) pure $ Just $ HM.unions definedNotes + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNoteReferences _ -> do+ targets <- toKnownFiles <$> useNoFile_ GetKnownTargets+ definedReferences <- catMaybes <$> for (HS.toList targets) (\nfp -> do+ references <- fmap snd <$> use MkGetNotesInFile nfp+ pure $ fmap (HM.map (fmap (nfp,))) references+ )+ pure $ Just $ foldl' (HM.unionWith (<>)) HM.empty definedReferences++err :: MonadError PluginError m => Text -> Maybe a -> m a+err s = maybe (throwError $ PluginInternalError s) pure++getNote :: NormalizedFilePath -> IdeState -> Position -> ExceptT PluginError (HandlerM c) (Maybe Text)+getNote nfp state (Position l c) = do+ contents <-+ err "Error getting file contents"+ =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp))+ line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst+ (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents))+ pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line+ where+ atPos c arr = case arr A.! 0 of+ -- We check if the line we are currently at contains a note+ -- reference. However, we need to know if the cursor is within the+ -- match or somewhere else. The second entry of the array contains+ -- the title of the note as extracted by the regex.+ (_, (c', len)) -> if c' <= c && c <= c' + len+ then Just (fst (arr A.! 1)) else Nothing++listReferences :: PluginMethodHandler IdeState Method_TextDocumentReferences+listReferences state _ param+ | Just nfp <- uriToNormalizedFilePath uriOrig+ = do+ let pos@(Position l _) = param ^. L.position+ noteOpt <- getNote nfp state pos+ case noteOpt of+ Nothing -> pure (InR Null)+ Just note -> do+ notes <- runActionE "notes.definedNoteReferencess" state $ useE MkGetNoteReferences nfp+ poss <- err ("Note reference (a comment of the form `{- Note [" <> note <> "] -}`) not found") (HM.lookup note notes)+ pure $ InL (mapMaybe (\(noteFp, pos@(Position l' _)) -> if l' == l then Nothing else Just (+ Location (fromNormalizedUri $ normalizedFilePathToUri noteFp) (Range pos pos))) poss)+ where+ uriOrig = toNormalizedUri $ param ^. (L.textDocument . L.uri)+listReferences _ _ _ = throwError $ PluginInternalError "conversion to normalized file path failed"+ jumpToNote :: PluginMethodHandler IdeState Method_TextDocumentDefinition jumpToNote state _ param | Just nfp <- uriToNormalizedFilePath uriOrig = do- let Position l c = param ^. L.position- contents <-- err "Error getting file contents"- =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp))- line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst- (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents))- let noteOpt = listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line+ noteOpt <- getNote nfp state (param ^. L.position) case noteOpt of Nothing -> pure (InR (InR Null)) Just note -> do@@ -93,17 +152,9 @@ )) where uriOrig = toNormalizedUri $ param ^. (L.textDocument . L.uri)- err s = maybe (throwError $ PluginInternalError s) pure- atPos c arr = case arr A.! 0 of- -- We check if the line we are currently at contains a note- -- reference. However, we need to know if the cursor is within the- -- match or somewhere else. The second entry of the array contains- -- the title of the note as extracted by the regex.- (_, (c', len)) -> if c' <= c && c <= c' + len- then Just (fst (arr A.! 1)) else Nothing jumpToNote _ _ _ = throwError $ PluginInternalError "conversion to normalized file path failed" -findNotesInFile :: NormalizedFilePath -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position))+findNotesInFile :: NormalizedFilePath -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position, HM.HashMap Text [Position])) findNotesInFile file recorder = do -- GetFileContents only returns a value if the file is open in the editor of -- the user. If not, we need to read it from disk.@@ -111,10 +162,13 @@ content <- case contentOpt of Just x -> pure $ Rope.toText x Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file- let matches = (A.! 1) <$> matchAllText noteRegex content- m = toPositions matches content- logWith recorder Debug $ LogNotesFound file (HM.toList m)- pure $ Just m+ let noteMatches = (A.! 1) <$> matchAllText noteRegex content+ notes = toPositions noteMatches content+ logWith recorder Debug $ LogNotesFound file (HM.toList notes)+ let refMatches = (A.! 1) <$> matchAllText noteRefRegex content+ refs = toPositions refMatches content+ logWith recorder Debug $ LogNoteReferencesFound file (HM.toList refs)+ pure $ Just (HM.mapMaybe (fmap fst . uncons) notes, refs) where uint = fromIntegral . toInteger -- the regex library returns the character index of the match. However@@ -129,7 +183,7 @@ let !c' = c + 1 (!n', !nc') = if char' == '\n' then (n + 1, c') else (n, nc) p@(!_, !_) = if char == c then- (xs, HM.insert name (Position (uint n') (uint (char - nc'))) m)+ (xs, HM.insertWith (<>) name [Position (uint n') (uint (char - nc'))] m) else (x:xs, m) in (p, (n', nc', c')) ) ((matches, HM.empty), (0, 0, 0))
plugins/hls-notes-plugin/test/NotesTest.hs view
@@ -11,6 +11,7 @@ main = defaultTestRunner $ testGroup "Notes" [ gotoNoteTests+ , noteReferenceTests ] runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a@@ -21,6 +22,21 @@ , testDirLocation = Left fp } act +noteReferenceTests :: TestTree+noteReferenceTests = testGroup "Note References"+ [+ testCase "multi_file" $ runSessionWithServer' testDataDir $ \dir -> do+ doc <- openDoc "NoteDef.hs" "haskell"+ waitForKickDone+ refs <- getReferences doc (Position 21 15) False+ let fp = dir </> "NoteDef.hs"+ liftIO $ refs @?= [+ Location (filePathToUri (dir </> "Other.hs")) (Range (Position 6 13) (Position 6 13)),+ Location (filePathToUri fp) (Range (Position 9 9) (Position 9 9)),+ Location (filePathToUri fp) (Range (Position 5 67) (Position 5 67))+ ]+ ]+ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" [@@ -29,13 +45,13 @@ waitForKickDone defs <- getDefinitions doc (Position 3 41) let fp = dir </> "NoteDef.hs"- liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))]))+ liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 11 9) (Position 11 9))])) , testCase "liberal_format" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 64) let fp = dir </> "NoteDef.hs"- liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))]))+ liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 21 11) (Position 21 11))])) , testCase "invalid_note" $ runSessionWithServer' testDataDir $ const $ do doc <- openDoc "NoteDef.hs" "haskell"@@ -54,7 +70,7 @@ waitForKickDone defs <- getDefinitions doc (Position 5 20) let fp = dir </> "NoteDef.hs"- liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))]))+ liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 15 6) (Position 15 6))])) ] testDataDir :: FilePath
plugins/hls-notes-plugin/test/testdata/NoteDef.hs view
@@ -6,6 +6,9 @@ -- The plugin is more liberal with the note definitions, see Note [Single line comments] -- It does not work on wrong note definitions, see Note [Not a valid Note] +-- We can also have multiple references to the same note, see+-- Note [Single line comments]+ {- Note [Returning zero from foo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is a big long form note, with very important info
plugins/hls-notes-plugin/test/testdata/Other.hs view
@@ -4,3 +4,4 @@ bar :: Int bar = 4 -- See @Note [Multiple notes in comment]@ in NoteDef+-- See Note [Single line comments]
plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -27,8 +28,13 @@ import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck)+import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Error (GhcHint (SuggestExtension),+ LanguageExtensionHint (..),+ diagnosticHints,+ msgEnvelopeErrorL) import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope) import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))@@ -69,13 +75,33 @@ deriving (Show, Eq, Ord) suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction-suggestPragmaProvider = mkCodeActionProvider suggest+suggestPragmaProvider = if ghcVersion /= GHC96 then+ mkCodeActionProvider suggestAddPragma+ else mkCodeActionProvider96 suggestAddPragma96 suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning -mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction mkCodeActionProvider mkSuggest state _plId+ (LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do+ verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId+ normalizedFilePath <- getNormalizedFilePathE (verTxtDocId ^. L.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+ activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case+ Nothing -> pure $ LSP.InL []+ Just fileDiags -> do+ let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags+ pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions++mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction+mkCodeActionProvider96 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@@ -89,7 +115,6 @@ 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.@@ -108,22 +133,17 @@ , 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 :: FileDiagnostic -> [PragmaEdit] suggestDisableWarning diagnostic- | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason+ | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL . attachedReason = [ ("Disable \"" <> w <> "\" warnings", OptGHC w) | JSON.String attachedReason <- Foldable.toList attachedReasons@@ -143,9 +163,23 @@ -- --------------------------------------------------------------------- -- | Offer to add a missing Language Pragma to the top of a file.+suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]+suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]+ where+ 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.+ []++-- | 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}+-- Kept for compatibility with ghc9.6 - it is missing some structured diagnostics+suggestAddPragma96 :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]+suggestAddPragma96 mDynflags Diagnostic {_message, _source} | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message where genPragma target =@@ -158,7 +192,7 @@ -- When the module failed to parse, we don't have access to its -- dynFlags. In that case, simply don't disable any pragmas. []-suggestAddPragma _ _ = []+suggestAddPragma96 _ _ = [] -- | Find all Pragmas are an infix of the search term. findPragma :: T.Text -> [T.Text]@@ -177,6 +211,20 @@ | FlagSpec{flagSpecName = T.pack -> name} <- xFlags , "Strict" /= name ]++suggestsExtension :: FileDiagnostic -> [Extension]+suggestsExtension message = case message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of+ Just s -> concat $ map (\case+ SuggestExtension s -> ghcHintSuggestsExtension s+ _ -> []) (diagnosticHints s)+ _ -> []++ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]+ghcHintSuggestsExtension (SuggestSingleExtension _ ext) = [ext]+ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_)) = [ext] -- ghc suggests any of those, we pick first+ghcHintSuggestsExtension (SuggestAnyExtension _ []) = []+ghcHintSuggestsExtension (SuggestExtensions _ ext) = ext+ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext] -- | All language pragmas, including the No- variants allPragmas :: [T.Text]
plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs view
@@ -32,17 +32,14 @@ TcModuleResult (TcModuleResult, tmrParsed, tmrTypechecked), TypeCheck (TypeCheck)) import Development.IDE.Core.Shake (IdeState)-import Development.IDE.GHC.Compat (ContextInfo (Use),- GenLocated (..), GhcPs,+import Development.IDE.GHC.Compat (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,+ SrcSpan, TcGblEnv (tcg_rdr_env), emptyUFM, globalRdrEnvElts, gre_imp, gre_name, locA,@@ -58,6 +55,9 @@ srcSpanStartLine, unitUFM) import Development.IDE.Types.Location (Position (Position), Range (Range), Uri)+import GHC.Iface.Ext.Types (ContextInfo (..), Identifier,+ IdentifierDetails (..), Span)+import GHC.Iface.Ext.Utils (RefMap) import Ide.Plugin.Error (PluginError (PluginRuleFailed), getNormalizedFilePathE, handleMaybe)
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs view
@@ -127,6 +127,7 @@ sourceText :: SourceText -> SDoc sourceText NoSourceText = text "NoSourceText"+ #if MIN_VERSION_ghc(9,7,0) sourceText (SourceText src) = text "SourceText" <+> ftext src #else@@ -134,13 +135,13 @@ #endif epaAnchor :: EpaLocation -> SDoc+ #if MIN_VERSION_ghc(9,9,0) epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s-#elif MIN_VERSION_ghc(9,5,0)- epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r #else- epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r+ epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r #endif+ #if MIN_VERSION_ghc(9,11,0) epaAnchor (EpaDelta s d cs) = text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstDataHtml' cs #else@@ -239,13 +240,8 @@ 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 #if MIN_VERSION_ghc(9,11,0) annotationAnnList :: EpAnn (AnnList ()) -> SDoc
plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs view
@@ -151,13 +151,8 @@ instance NFData GetAnnotatedParsedSource type instance RuleResult GetAnnotatedParsedSource = ParsedSource -#if MIN_VERSION_ghc(9,5,0) instance Show (HsModule GhcPs) where show _ = "<HsModule GhcPs>"-#else-instance Show HsModule where- show _ = "<HsModule GhcPs>"-#endif -- | Get the latest version of the annotated parse source with comments. getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules ()@@ -622,17 +617,10 @@ 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.@@ -735,26 +723,16 @@ 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 ------------------------------------------------------------------------------
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -18,7 +18,6 @@ ) where import Control.Applicative ((<|>))-import Control.Applicative.Combinators.NonEmpty (sepBy1) import Control.Arrow (second, (&&&), (>>>))@@ -73,15 +72,15 @@ import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options-import GHC (- DeltaPos (..),+import GHC (DeltaPos (..), EpAnn (..), LEpaComment)+import GHC.Iface.Ext.Types (ContextInfo (..),+ IdentifierDetails (..)) 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 (..),@@ -101,7 +100,6 @@ type (|?) (InL, InR), uriToFilePath) import qualified Text.Fuzzy.Parallel as TFP-import qualified Text.Regex.Applicative as RE import Text.Regex.TDFA ((=~), (=~~)) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]@@ -109,9 +107,9 @@ #if !MIN_VERSION_ghc(9,9,0) import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst) import GHC (AddEpAnn (AddEpAnn),- AnnsModule (am_main), Anchor (anchor_op), AnchorOperation (..),+ AnnsModule (am_main), EpaLocation (..)) #endif @@ -121,15 +119,14 @@ EpaLocation, EpaLocation' (..), HasLoc (..))-import GHC.Types.SrcLoc (srcSpanToRealSrcSpan) #endif+ #if MIN_VERSION_ghc(9,11,0)-import GHC (EpaLocation,- AnnsModule (am_where),+import GHC (AnnsModule (am_where),+ EpToken (..),+ EpaLocation, EpaLocation' (..),- HasLoc (..),- EpToken (..))-import GHC.Types.SrcLoc (srcSpanToRealSrcSpan)+ HasLoc (..)) #endif @@ -272,19 +269,11 @@ 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 <$> ideclAs) == Just qual) isWantedModule _ _ _ = False@@ -682,14 +671,16 @@ indexedContent name (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do- let go bag lsigs =+ let emptyBag bag = #if MIN_VERSION_ghc(9,11,0)- if null bag+ null bag #else- if isEmptyBag bag+ isEmptyBag bag #endif- then []- else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag+ go bag lsigs =+ if emptyBag bag+ then []+ else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag case grhssLocalBinds of (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs _ -> []@@ -860,7 +851,6 @@ | 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"@@ -871,17 +861,6 @@ , 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]@@ -1161,17 +1140,10 @@ | 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@@ -1509,11 +1481,6 @@ >>= (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)@@ -1522,84 +1489,13 @@ "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+ (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) 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 {..} = 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 '.'-- -- | A Backward compatible implementation of `lookupOccEnv_AllNameSpaces` for -- GHC <=9.6 --@@ -1742,11 +1638,7 @@ -- 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' #if MIN_VERSION_ghc(9,11,0)@@ -1759,8 +1651,8 @@ EpAnnNotUsed -> Nothing #endif #if MIN_VERSION_ghc(9,11,0)- filterWhere (EpTok loc) = Just loc- filterWhere _ = Nothing+ filterWhere (EpTok loc) = Just loc+ filterWhere _ = Nothing #else filterWhere (AddEpAnn AnnWhere loc) = Just loc filterWhere _ = Nothing@@ -1770,11 +1662,8 @@ #if MIN_VERSION_ghc(9,9,0) epaLocationToLine (EpaSpan sp) = fmap (srcLocLine . realSrcSpanEnd) $ srcSpanToRealSrcSpan sp-#elif MIN_VERSION_ghc(9,5,0)- epaLocationToLine (EpaSpan sp _)- = Just . srcLocLine . realSrcSpanEnd $ sp #else- epaLocationToLine (EpaSpan sp)+ epaLocationToLine (EpaSpan sp _) = Just . srcLocLine . realSrcSpanEnd $ sp #endif #if MIN_VERSION_ghc(9,11,0)@@ -1799,7 +1688,7 @@ #if MIN_VERSION_ghc(9,11,0) anchorOpLine :: EpaLocation' a -> Int- anchorOpLine EpaSpan{} = 0+ anchorOpLine EpaSpan{} = 0 anchorOpLine (EpaDelta _ (SameLine _) _) = 0 anchorOpLine (EpaDelta _ (DifferentLine line _) _) = line #elif MIN_VERSION_ghc(9,9,0)@@ -2058,21 +1947,12 @@ -- | 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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -22,11 +22,13 @@ import Data.Functor ((<&>)) import Data.IORef.Extra import qualified Data.Map as Map-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe,+ maybeToList) import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (pluginHandlers)+import Development.IDE.Core.PluginUtils (activeDiagnosticsInRange) import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint@@ -53,39 +55,43 @@ ------------------------------------------------------------------------------------------------- runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config 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 (_, mbContents) -> fmap Rope.toText mbContents- 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+runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range _) codeAction+ | Just nfp <- toNormalizedFilePath' <$> uriToFilePath uri = do+ let runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure (Just nfp)) >>= 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 (_, mbContents) -> fmap Rope.toText mbContents+ 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+ diags <- concat . maybeToList <$> activeDiagnosticsInRange (shakeExtras state) nfp _range+ results <- liftIO $+ sequence+ [+ runReaderT (runExceptT codeAction) CodeActionArgs {..}+ | caaDiagnostic <- diags+ ]+ let (_errs, successes) = partitionEithers results+ pure $ concat successes+ | otherwise = pure [] + 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@@ -145,7 +151,7 @@ caaHar :: IO (Maybe HieAstResult), caaBindings :: IO (Maybe Bindings), caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult),- caaDiagnostic :: Diagnostic+ caaDiagnostic :: FileDiagnostic } -- | There's no concurrency in each provider,@@ -223,6 +229,9 @@ toCodeAction = toCodeAction3 caaIdeOptions instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where+ toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f (fdLspDiagnostic x)++instance ToCodeAction r => ToCodeAction (FileDiagnostic -> 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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -63,6 +63,7 @@ #if MIN_VERSION_ghc(9,9,0) import GHC (NoAnn (..))+import GHC (EpAnnComments (..)) #endif ------------------------------------------------------------------------------@@ -139,10 +140,8 @@ go :: LHsType GhcPs -> Rewrite #if MIN_VERSION_ghc(9,9,0) go lHsType@(makeDeltaAst -> L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA lHsType) $ \_ -> do-#elif MIN_VERSION_ghc(9,4,0)- go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do #else- go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do+ 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@@ -151,11 +150,7 @@ [] -> 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@@ -172,15 +167,11 @@ 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) #if MIN_VERSION_ghc(9,9,0)- let l'' = fmap (addParensToCtxt close_dp) l'+ let l'' = moveCommentsToTheEnd $ fmap (addParensToCtxt close_dp) l' #else let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' #endif@@ -196,11 +187,7 @@ #endif _ -> 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@@ -208,11 +195,7 @@ 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 #if MIN_VERSION_ghc(9,11,0) annCtxt = AnnContext (Just (EpUniTok (epl 1) NormalSyntax)) [EpTok (epl 0) | needsParens] [EpTok (epl 0) | needsParens] #else@@ -223,6 +206,26 @@ return $ reLocA $ L lTop $ HsQualTy noExtField context ast +#if MIN_VERSION_ghc(9,9,0)+-- | This moves comment annotation toward the end of the block+-- This is useful when extending a block, so the comment correctly appears+-- after.+--+-- See https://github.com/haskell/haskell-language-server/issues/4648 for+-- discussion.+--+-- For example, the following element, @(Foo) => -- hello@, when introducing an+-- additionnal constraint, `Bar`, instead of getting `@(Foo, Bar) => -- hello@,+-- we get @(Foo, -- hello Bar) =>@+--+-- This is a bit painful that the pretty printer is not able to realize that it+-- introduces the token `=>` inside the comment and instead does something with+-- meaning, but that's another story.+moveCommentsToTheEnd :: EpAnn ann -> EpAnn ann+moveCommentsToTheEnd (EpAnn entry anns (EpaComments priors)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors})+moveCommentsToTheEnd (EpAnn entry anns (EpaCommentsBalanced priors following)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors <> following})+#endif+ liftParseAST :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)@@ -264,11 +267,7 @@ 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@@ -280,9 +279,7 @@ 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)@@ -299,11 +296,7 @@ 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@@ -333,11 +326,7 @@ 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 #if MIN_VERSION_ghc(9,9,0) go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie) _)) : _xs)@@ -355,9 +344,7 @@ 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,11,0)@@ -374,12 +361,7 @@ docs #endif --#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 #if MIN_VERSION_ghc(9,9,0) go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies' docs)) : xs)@@ -389,11 +371,7 @@ -- 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,9,0) docs@@ -419,15 +397,9 @@ 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]) #if MIN_VERSION_ghc(9,9,0)@@ -451,9 +423,7 @@ let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (epl 0) parentRdr' #endif else IEName-#if MIN_VERSION_ghc(9,5,0) noExtField-#endif parentRdr' parentRdr' = modifyAnns parentRdr $ \case #if MIN_VERSION_ghc(9,11,0)@@ -463,9 +433,7 @@ #endif other -> other childLIE = reLocA $ L srcChild $ IEName-#if MIN_VERSION_ghc(9,5,0) noExtField-#endif childRdr #if MIN_VERSION_ghc(9,11,0) listAnn = (Nothing, (EpTok (epl 1), NoEpTok, NoEpTok, EpTok (epl 0)))@@ -482,11 +450,7 @@ #endif 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.@@ -527,11 +491,7 @@ 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@@ -545,17 +505,10 @@ 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 $ setEntryDP (makeDeltaAst imports) (SameLine 1)-#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 ->@@ -568,7 +521,7 @@ Nothing -> do #if MIN_VERSION_ghc(9,11,0) let ann :: EpAnn (AnnList (EpToken "hiding", [EpToken ","]))- ann = noAnnSrcSpanDP0 + ann = noAnnSrcSpanDP0 #elif MIN_VERSION_ghc(9,9,0) let ann = noAnnSrcSpanDP0 #else@@ -597,9 +550,7 @@ 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)@@ -613,11 +564,7 @@ #endif 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 @@ -632,11 +579,7 @@ 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 =
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs view
@@ -10,6 +10,7 @@ import Development.IDE.GHC.Dump (showAstDataHtml) import GHC.Stack import GHC.Utils.Outputable+import System.Directory.Extra (createDirectoryIfMissing) import System.Environment.Blank (getEnvDefault) import System.IO.Unsafe import Text.Printf@@ -37,6 +38,7 @@ doTrace = unsafePerformIO $ do u <- U.newUnique let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)+ createDirectoryIfMissing True "/tmp/hls" writeFile htmlDumpFileName $ renderDump htmlDump return $ unlines [prettyCallStack callStack ++ ":"
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -24,13 +24,7 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,4,0)-import GHC.Parser.Annotation (IsUnicodeSyntax (..),- TrailingAnn (..))-import Language.Haskell.GHC.ExactPrint (d1)-#endif--#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,9,0)+#if MIN_VERSION_ghc(9,6,0) && !MIN_VERSION_ghc(9,9,0) import Development.IDE.GHC.ExactPrint (epl) import GHC.Parser.Annotation (TokenLocation (..)) #endif@@ -50,8 +44,9 @@ IsUnicodeSyntax (NormalSyntax)) import Language.Haskell.GHC.ExactPrint (d1, setEntryDP) #endif+ #if MIN_VERSION_ghc(9,11,0)-import GHC.Parser.Annotation (EpToken(..))+import GHC.Parser.Annotation (EpToken (..)) #endif -- When GHC tells us that a variable is not bound, it will tell us either:@@ -79,27 +74,33 @@ -- addArgToMatch "foo" `bar arg1 arg2 = ...` -- => (`bar arg1 arg2 foo = ...`, 2) addArgToMatch :: T.Text -> GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))) -> (GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))), Int)++-- NOTE: The code duplication within CPP clauses avoids a parse error with+-- `stylish-haskell`. #if MIN_VERSION_ghc(9,11,0) addArgToMatch name (L locMatch (Match xMatch ctxMatch (L l pats) rhs)) =-#else+ let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name+ newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName+ -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between+ -- the newly added pattern and the rest+ indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs))+ indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs }+ in (L locMatch (Match xMatch ctxMatch (L l (pats <> [newPat])) (indentRhs rhs)), Prelude.length pats)+#elif MIN_VERSION_ghc(9,9,0) addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) =-#endif-#if MIN_VERSION_ghc(9,9,0) let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between -- the newly added pattern and the rest indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs)) indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs }+ in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats) #else+addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) indentRhs = id-#endif-#if MIN_VERSION_ghc(9,11,0)- in (L locMatch (Match xMatch ctxMatch (L l (pats <> [newPat])) (indentRhs rhs)), Prelude.length pats)-#else- in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats)+ in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats) #endif -- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind.@@ -186,23 +187,15 @@ , L wildCardAnn $ HsWildCardTy NoEpTok #else , L wildCardAnn $ HsWildCardTy noExtField-#endif +#endif )-#elif MIN_VERSION_ghc(9,4,0)+#else 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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs view
@@ -2,78 +2,106 @@ ( suggestFillTypeWildcard ) where -import Data.Char-import qualified Data.Text as T-import Language.LSP.Protocol.Types (Diagnostic (..),- TextEdit (TextEdit))+import Control.Lens+import Data.Maybe (isJust)+import qualified Data.Text as T+import Development.IDE (FileDiagnostic (..),+ fdStructuredMessageL,+ printOutputable)+import Development.IDE.GHC.Compat hiding (vcat)+import Development.IDE.GHC.Compat.Error+import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)+import GHC.Tc.Errors.Types (ErrInfo (..))+import Language.LSP.Protocol.Types (Diagnostic (..),+ TextEdit (TextEdit)) -suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillTypeWildcard Diagnostic{_range=_range,..}+suggestFillTypeWildcard :: FileDiagnostic -> [(T.Text, TextEdit)]+suggestFillTypeWildcard diag@FileDiagnostic{fdLspDiagnostic = Diagnostic {..}} -- 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)]+ | isWildcardDiagnostic diag+ , typeSignature <- extractWildCardTypeSignature diag =+ [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] | otherwise = [] +isWildcardDiagnostic :: FileDiagnostic -> Bool+isWildcardDiagnostic =+ maybe False (isJust . (^? _TypeHole) . hole_sort) . diagReportHoleError++-- | Extract the 'Hole' out of a 'FileDiagnostic'+diagReportHoleError :: FileDiagnostic -> Maybe Hole+diagReportHoleError diag = do+ solverReport <-+ diag+ ^? fdStructuredMessageL+ . _SomeStructuredMessage+ . msgEnvelopeErrorL+ . _TcRnMessage+ . _TcRnSolverReport+ . _1+ (hole, _) <- solverReport ^? reportContentL . _ReportHoleError++ Just hole+ -- | 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+extractWildCardTypeSignature :: FileDiagnostic -> T.Text+extractWildCardTypeSignature diag =+ case hole_ty <$> diagReportHoleError diag of+ Just ty+ | isTopLevel || not (isApp ty) || enclosed ty -> printOutputable ty+ | otherwise -> "(" <> printOutputable ty <> ")" Nothing -> error "GHC provided invalid type"- Just (firstChr, _) -> not (T.null sig) && (firstChr, T.last sig) `elem` [('(', ')'), ('[', ']')]+ where+ isTopLevel :: Bool+ isTopLevel =+ maybe False errorMessageRefersToToplevelHole (diagErrInfoContext diag) --- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@.+ isApp :: Type -> Bool+ isApp (AppTy _ _) = True+ isApp (TyConApp _ (_ : _)) = True+ isApp (FunTy{}) = True+ isApp _ = False++ enclosed :: Type -> Bool+ enclosed (TyConApp con _)+ | con == listTyCon || isTupleTyCon con = True+ enclosed _ = False++-- | Extract the 'ErrInfo' context out of a 'FileDiagnostic' and render it to+-- 'Text'+diagErrInfoContext :: FileDiagnostic -> Maybe T.Text+diagErrInfoContext diag = do+ (_, detailedMsg) <-+ diag+ ^? fdStructuredMessageL+ . _SomeStructuredMessage+ . msgEnvelopeErrorL+ . _TcRnMessageWithCtx+ . _TcRnMessageWithInfo+ let TcRnMessageDetailed err _ = detailedMsg+ ErrInfo errInfoCtx _ = err++ Just (printOutputable errInfoCtx)++-- | Detect whether user wrote something like @foo :: _@ or @foo :: Maybe _@. -- 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+-- When type hole is at toplevel then the ErrInfo context starts 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]+-- Just "In the type signature: decl :: _" -- -- 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]+-- Just "In the first argument of ‘HsDecl’\nIn the type signature: decl :: HsDecl _" 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+ "In the type signature:" `T.isPrefixOf` msg+ && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') msg
plugins/hls-refactor-plugin/test/Main.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-}@@ -701,6 +701,10 @@ "func::Integer -> Integer -> Integer" , "func x y = x + y" ]+ , testNoUseTypeSignature "ignores typed holes"+ [ "func :: a -> a"+ , "func x = _"+ ] , testGroup "add parens if hole is part of bigger type" [ testUseTypeSignature "subtype 1" [ "func :: _ -> Integer -> Integer"@@ -736,20 +740,34 @@ -- | 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"+ let expectedContentAfterAction = T.unlines $ fileStart : textOut 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- ]++ (Just addSignature) <- getUseTypeSigAction doc executeCodeAction addSignature contentAfterAction <- documentContents doc liftIO $ expectedContentAfterAction @=? contentAfterAction + testNoUseTypeSignature name textIn = testSession name $ do+ let content = T.unlines $ fileStart : textIn+ doc <- createDoc "Testing.hs" "haskell" content+ codeAction <- getUseTypeSigAction doc+ liftIO $ Nothing @=? codeAction + fileStart = "module Testing where"++ getUseTypeSigAction docIn = do+ _ <- waitForDiagnostics+ actionsOrCommands <- getAllCodeActions docIn++ let addSignatures =+ [ action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands+ , "Use type signature" `T.isPrefixOf` actionTitle+ ]+ pure $ listToMaybe addSignatures++ removeImportTests :: TestTree removeImportTests = testGroup "remove import actions" [ testSession "redundant" $ do@@ -1157,7 +1175,7 @@ , "x :: (:~:) [] []" , "x = Refl" ])- (Range (Position 3 17) (Position 3 18))+ (Range (Position 3 4) (Position 3 8)) [ "Add (:~:)(..) to the import list of Data.Type.Equality" , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] (T.unlines@@ -1221,7 +1239,7 @@ , "import ModuleA as A (stuffB)" , "main = print (stuffB .* stuffB)" ])- (Range (Position 2 17) (Position 2 18))+ (Range (Position 2 22) (Position 2 24)) ["Add (.*) to the import list of ModuleA"] (T.unlines [ "module ModuleB where"@@ -1235,7 +1253,7 @@ , "import Data.List.NonEmpty (fromList)" , "main = case (fromList []) of _ :| _ -> pure ()" ])- (Range (Position 2 5) (Position 2 6))+ (Range (Position 2 31) (Position 2 33)) [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" ]@@ -1252,7 +1270,7 @@ , "import Data.Maybe (catMaybes)" , "x = Just 10" ])- (Range (Position 3 5) (Position 2 6))+ (Range (Position 3 4) (Position 3 8)) [ "Add Maybe(Just) to the import list of Data.Maybe" , "Add Maybe(..) to the import list of Data.Maybe" ]@@ -1359,8 +1377,7 @@ [ "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+ , testSession "extend single line qualified import with value" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" , "stuffA :: Double"@@ -1485,7 +1502,7 @@ , "import ModuleA ()" , "foo = bar" ])- (Range (Position 3 17) (Position 3 18))+ (Range (Position 3 6) (Position 3 9)) ["Add bar to the import list of ModuleA", "Add bar to the import list of ModuleB"] (T.unlines@@ -1502,7 +1519,7 @@ , "x :: (:~:) [] []" , "x = Refl" ])- (Range (Position 3 17) (Position 3 18))+ (Range (Position 3 4) (Position 3 8)) [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" , "Add (:~:)(..) to the import list of Data.Type.Equality"] (T.unlines@@ -1552,8 +1569,7 @@ ) (Range (Position 2 3) (Position 2 7)) )- , ignoreForGhcVersions [GHC94] "Diagnostic message has no suggestions" $- testSession "type constructor name same as data constructor name" $ template+ , testSession "type constructor name same as data constructor name" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" , "newtype Foo = Foo Int"@@ -1855,7 +1871,7 @@ suggestAddRecordFieldImportTests :: TestTree suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" [ testGroup "The field is suggested when an instance resolution failure occurs"- ([ ignoreForGhcVersions [GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest+ ([ ignoreForGhcVersions [GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest ] ++ [ theTestIndirect qualifiedGhcRecords polymorphicType@@ -2427,7 +2443,7 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics action <- pickActionWithTitle "Define select :: Int -> Bool"- =<< getCodeActions docB (R 1 0 0 50)+ =<< getCodeActions docB (R 1 8 1 14) executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines expected@@ -2451,7 +2467,7 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics action <- pickActionWithTitle "Define select :: Int -> Bool"- =<< getCodeActions docB (R 1 0 0 50)+ =<< getCodeActions docB (R 1 8 1 14) executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines expected@@ -2619,9 +2635,7 @@ , "" , "f = 1" ]- (if ghcVersion >= GHC94- then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable", Nothing) ]- else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint", Nothing) ])+ [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable", Nothing) ] "Add type annotation ‘Integer’ to ‘1’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A (f) where"@@ -2638,9 +2652,7 @@ , " let x = 3" , " in x" ]- (if ghcVersion >= GHC94- then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable", Nothing) ]- else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint", Nothing) ])+ [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable", Nothing) ] "Add type annotation ‘Integer’ to ‘3’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where"@@ -2658,9 +2670,7 @@ , " let x = let y = 5 in y" , " in x" ]- (if ghcVersion >= GHC94- then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable", Nothing) ]- else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint", Nothing) ])+ [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable", Nothing) ] "Add type annotation ‘Integer’ to ‘5’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where"@@ -2679,15 +2689,9 @@ , "" , "f = seq \"debug\" traceShow \"debug\"" ]- (if ghcVersion >= GHC94- then- [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable", Nothing)- , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable", Nothing)- ]- else- [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint", Nothing)- , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint", Nothing)- ])+ [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable", Nothing)+ , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable", Nothing)+ ] ("Add type annotation ‘" <> stringLit <> "’ to ‘\"debug\"’") [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2707,9 +2711,7 @@ , "" , "f a = traceShow \"debug\" a" ]- (if ghcVersion >= GHC94- then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable", Nothing) ]- else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint", Nothing) ])+ [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable", Nothing) ] ("Add type annotation ‘" <> stringLit <> "’ to ‘\"debug\"’") [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2729,9 +2731,7 @@ , "" , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ]- (if ghcVersion >= GHC94- then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable", Nothing) ]- else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint", Nothing) ])+ [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable", Nothing) ] ("Add type annotation ‘"<> stringLit <>"’ to ‘\"debug\"’") [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2768,7 +2768,7 @@ [ "module ModuleB where" , "import ModuleA(Constructor)" ])- (Range (Position 1 10) (Position 1 11))+ (Range (Position 1 15) (Position 1 26)) "Fix import of A(Constructor)" (T.unlines [ "module ModuleB where"@@ -3054,6 +3054,21 @@ , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] + -- See https://github.com/haskell/haskell-language-server/issues/4648+ -- When haddock comment appears after the =>, code action was introducing the+ -- new constraint in the comment+ incompleteConstraintSourceCodeWithCommentInTypeSignature :: T.Text -> T.Text+ incompleteConstraintSourceCodeWithCommentInTypeSignature constraint =+ T.unlines++ [ "module Testing where"+ , "foo "+ , " :: ("<> constraint <> ") =>"+ , " -- This is a comment"+ , " m ()"+ , "foo = pure ()"+ ]+ missingMonadConstraint constraint = T.unlines [ "module Testing where" , "f :: " <> constraint <> "m ()"@@ -3098,6 +3113,11 @@ (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") , checkCodeAction+ "preexisting constraint, with haddock comment in type signature"+ "Add `Applicative m` to the context of the type signature for `foo`"+ (incompleteConstraintSourceCodeWithCommentInTypeSignature "")+ (incompleteConstraintSourceCodeWithCommentInTypeSignature " Applicative m")+ , checkCodeAction "missing Monad constraint" "Add `Monad m` to the context of the type signature for `f`" (missingMonadConstraint "")@@ -3359,7 +3379,7 @@ executeCodeAction chosenAction modifiedCode <- documentContents doc liftIO $ expectedCode @=? modifiedCode- issue806 = if ghcVersion >= GHC912 then+ issue806 = if ghcVersion >= GHC910 then "hello = print" >:: "hello :: GHC.Types.ZonkAny 0 -> IO ()" -- GHC now returns ZonkAny 0 instead of Any. https://gitlab.haskell.org/ghc/ghc/-/issues/25895 else "hello = print" >:: "hello :: GHC.Types.Any -> IO ()" -- Documents current behavior outlined in #806@@ -3405,8 +3425,7 @@ ] (R 2 0 2 11) "Export ‘bar’"- , ignoreForGhcVersions [GHC94] "Diagnostic message has no suggestions" $- testSession "type is exported but not the constructor of same name" $ templateNoAction+ , testSession "type is exported but not the constructor of same name" $ templateNoAction [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A (Foo) where" , "data Foo = Foo"@@ -4049,6 +4068,3 @@ -- @/var@ withTempDir :: (FilePath -> IO a) -> IO a withTempDir f = System.IO.Extra.withTempDir $ (canonicalizePath >=> f)--brokenForGHC94 :: String -> TestTree -> TestTree-brokenForGHC94 = knownBrokenForGhcVersions [GHC94]
plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -8,7 +8,6 @@ module Ide.Plugin.Rename (descriptor, E.Log) where -import Compat.HieTypes import Control.Lens ((^.)) import Control.Monad import Control.Monad.Except (ExceptT, throwError)@@ -25,7 +24,6 @@ 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)@@ -42,7 +40,14 @@ import Development.IDE.Plugin.CodeAction import Development.IDE.Spans.AtPoint import Development.IDE.Types.Location+import GHC.Iface.Ext.Types (HieAST (..),+ HieASTs (..),+ NodeOrigin (..),+ SourcedNodeInfo (..))+import GHC.Iface.Ext.Utils (generateReferencesMap)+import HieDb ((:.) (..)) import HieDb.Query+import HieDb.Types (RefRow (refIsGenerated)) import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.PluginUtils@@ -196,6 +201,8 @@ dbRefs <- case nameModule_maybe name of Nothing -> pure [] Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb ->+ -- See Note [Generated references]+ filter (\(refRow HieDb.:. _) -> refIsGenerated refRow) <$> findReferences hieDb True@@ -230,15 +237,29 @@ -- which is bad (see https://github.com/haskell/haskell-language-server/issues/3799) fmap removeGenerated $ runActionE "Rename.GetHieAst" state $ useE 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.+{- Note [Generated references]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC inserts `Use`s of record constructor everywhere where its record selectors are used,+which leads to record fields being renamed whenever corresponding constructor is renamed.+see https://github.com/haskell/haskell-language-server/issues/2915+To work around this, we filter out compiler-generated references.+-} removeGenerated :: HieAstResult -> HieAstResult-removeGenerated HAR{..} = HAR{hieAst = go hieAst,..}+removeGenerated HAR{..} =+ HAR{hieAst = sourceOnlyAsts, refMap = sourceOnlyRefMap, ..} 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)+ goAsts :: HieASTs a -> HieASTs a+ goAsts (HieASTs asts) = HieASTs (fmap goAst asts)++ goAst :: HieAST a -> HieAST a+ goAst (Node (SourcedNodeInfo sniMap) sp children) =+ let sourceOnlyNodeInfos = SourcedNodeInfo $ M.delete GeneratedInfo sniMap+ in Node sourceOnlyNodeInfos sp $ map goAst children++ sourceOnlyAsts = goAsts hieAst+ -- Also need to regenerate the RefMap, because the one in HAR+ -- is generated from HieASTs containing GeneratedInfo+ sourceOnlyRefMap = generateReferencesMap $ getAsts sourceOnlyAsts 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
plugins/hls-rename-plugin/test/Main.hs view
@@ -24,6 +24,11 @@ tests = testGroup "Rename" [ goldenWithRename "Data constructor" "DataConstructor" $ \doc -> rename doc (Position 0 15) "Op"+ , goldenWithRename "Data constructor with fields" "DataConstructorWithFields" $ \doc ->+ rename doc (Position 1 13) "FooRenamed"+ , knownBrokenForGhcVersions [GHC96, GHC98] "renaming Constructor{..} with RecordWildcard removes .." $+ goldenWithRename "Data constructor with fields" "DataConstructorWithFieldsRecordWildcards" $ \doc ->+ rename doc (Position 1 13) "FooRenamed" , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> rename doc (Position 2 1) "quux" , goldenWithRename "Field Puns" "FieldPuns" $ \doc ->@@ -113,7 +118,7 @@ goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act -renameExpectError :: (TResponseError Method_TextDocumentRename) -> TextDocumentIdentifier -> Position -> Text -> Session ()+renameExpectError :: TResponseError Method_TextDocumentRename -> TextDocumentIdentifier -> Position -> Text -> Session () renameExpectError expectedError doc pos newName = do let params = RenameParams Nothing doc pos newName rsp <- request SMethod_TextDocumentRename params
+ plugins/hls-rename-plugin/test/testdata/DataConstructorWithFields.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NamedFieldPuns #-}+data Foo = FooRenamed { a :: Int, b :: Bool }++foo1 :: Foo+foo1 = FooRenamed { a = 1, b = True }++foo2 :: Foo+foo2 = FooRenamed 1 True++fun1 :: Foo -> Int+fun1 FooRenamed {a} = a++fun2 :: Foo -> Int+fun2 FooRenamed {a = i} = i
+ plugins/hls-rename-plugin/test/testdata/DataConstructorWithFields.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NamedFieldPuns #-}+data Foo = Foo { a :: Int, b :: Bool }++foo1 :: Foo+foo1 = Foo { a = 1, b = True }++foo2 :: Foo+foo2 = Foo 1 True++fun1 :: Foo -> Int+fun1 Foo {a} = a++fun2 :: Foo -> Int+fun2 Foo {a = i} = i
+ plugins/hls-rename-plugin/test/testdata/DataConstructorWithFieldsRecordWildcards.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+data Foo = FooRenamed { a :: Int, b :: Bool }++fun :: Foo -> Int+fun FooRenamed {..} = a
+ plugins/hls-rename-plugin/test/testdata/DataConstructorWithFieldsRecordWildcards.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+data Foo = Foo { a :: Int, b :: Bool }++fun :: Foo -> Int+fun Foo {..} = a
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs view
@@ -465,11 +465,7 @@ ] | 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@@ -736,7 +732,6 @@ ideclPkgQual = NoRawPkgQual -#if MIN_VERSION_ghc(9,5,0) ideclImportList = Nothing ideclExt = GHCGHC.XImportDeclPass { ideclAnn =@@ -748,11 +743,6 @@ , ideclSourceText = ideclSourceSrc , ideclImplicit = ideclImplicit }-#else- ideclExt = GHCGHC.EpAnnNotUsed- ideclHiding = Nothing-#endif- reuseParsedModule :: IdeState -> NormalizedFilePath -> IO (FixityEnv, Annotated GHCGHC.ParsedSource) reuseParsedModule state f = do
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}@@ -43,6 +44,8 @@ getVirtualFile) import Development.IDE.GHC.Compat hiding (Warning) import Development.IDE.GHC.Compat.Util (mkFastString)+import GHC.Iface.Ext.Types (HieASTs (getAsts),+ pattern HiePath) import Ide.Logger (logWith) import Ide.Plugin.Error (PluginError (PluginInternalError), getNormalizedFilePathE,
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs view
@@ -20,6 +20,10 @@ import Data.Text (Text, unpack) import Development.IDE (HieKind (HieFresh, HieFromDisk)) import Development.IDE.GHC.Compat+import GHC.Iface.Ext.Types (BindType (..),+ ContextInfo (..),+ DeclType (..), HieType (..),+ HieTypeFlat, TypeIndex) import Ide.Plugin.SemanticTokens.Types import Ide.Plugin.SemanticTokens.Utils (mkRange) import Language.LSP.Protocol.Types (LspEnum (knownValues),
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs view
@@ -11,6 +11,9 @@ import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat+import GHC.Iface.Ext.Types (ContextInfo, Identifier,+ IdentifierDetails (..))+import GHC.Iface.Ext.Utils (RefMap) import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, HsSemanticTokenType (TModule),
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs view
@@ -16,8 +16,8 @@ import GHC.TypeLits (KnownSymbol) import Ide.Plugin.Properties (KeyNameProxy, NotElem, Properties,- PropertyKey (type PropertyKey),- PropertyType (type TEnum),+ PropertyKey (PropertyKey),+ PropertyType (TEnum), defineEnumProperty, emptyProperties) import Ide.Plugin.SemanticTokens.Types
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs view
@@ -22,6 +22,10 @@ import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToCodePointRange)+import GHC.Iface.Ext.Types (HieAST (..), Identifier,+ NodeInfo (..),+ NodeOrigin (..),+ SourcedNodeInfo (..)) import Ide.Plugin.SemanticTokens.Types (HsSemanticTokenType (TModule), RangeHsSemanticTokenTypes (..)) import Language.LSP.Protocol.Types (Position (Position),
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs view
@@ -10,16 +10,16 @@ import Control.DeepSeq (NFData (rnf), rwhnf) import qualified Data.Array as A import Data.Default (Default (def))+import Data.Text (Text) 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 GHC.Iface.Ext.Types (TypeIndex) import Ide.Plugin.Error (PluginError) import Language.Haskell.TH.Syntax (Lift)+import Language.LSP.Protocol.Types -- !!!! order of declarations matters deriving enum and ord
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs view
@@ -10,6 +10,11 @@ import qualified Data.Map.Strict as Map import Development.IDE (Position (..), Range (..)) import Development.IDE.GHC.Compat+import GHC.Iface.Ext.Types (BindType (..), ContextInfo (..),+ DeclType (..), Identifier,+ IdentifierDetails (..),+ RecFieldContext (..), Span)+import GHC.Iface.Ext.Utils (RefMap) import Prelude hiding (length, span) deriving instance Show DeclType
+ plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE GADTs #-}++module Ide.Plugin.SignatureHelp (descriptor) where++import Control.Arrow ((>>>))+import Control.Monad.Trans.Except (ExceptT (ExceptT))+import Data.Bifunctor (bimap)+import Data.Function ((&))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Development.IDE (DocAndTyThingMap (DKMap),+ GetDocMap (GetDocMap),+ GetHieAst (GetHieAst),+ HieAstResult (HAR, hieAst, hieKind),+ HieKind (..),+ IdeState (shakeExtras),+ Pretty (pretty),+ Recorder, WithPriority,+ printOutputableOneLine,+ useWithStaleFast)+import Development.IDE.Core.PluginUtils (runIdeActionE,+ useWithStaleFastE)+import Development.IDE.Core.PositionMapping (fromCurrentPosition)+import Development.IDE.GHC.Compat (FastStringCompat, Name,+ RealSrcSpan,+ getSourceNodeIds,+ isAnnotationInNodeInfo,+ mkRealSrcLoc,+ mkRealSrcSpan, ppr,+ sourceNodeInfo)+import Development.IDE.GHC.Compat.Util (LexicalFastString (LexicalFastString))+import Development.IDE.Spans.Common (ArgDocMap, DocMap,+ SpanDoc (..),+ SpanDocUris (SpanDocUris),+ spanDocToMarkdown)+import GHC.Core.Map.Type (deBruijnize)+import GHC.Core.Type (FunTyFlag (FTF_T_T),+ Type, dropForAlls,+ splitFunTy_maybe)+import GHC.Data.Maybe (rightToMaybe)+import GHC.Iface.Ext.Types (ContextInfo (Use),+ HieAST (nodeChildren, nodeSpan),+ HieASTs (getAsts),+ IdentifierDetails (identInfo, identType),+ nodeType)+import GHC.Iface.Ext.Utils (smallestContainingSatisfying)+import GHC.Types.Name.Env (lookupNameEnv)+import GHC.Types.SrcLoc (isRealSubspanOf)+import Ide.Plugin.Error (getNormalizedFilePathE)+import Ide.Types (PluginDescriptor (pluginHandlers),+ PluginId,+ PluginMethodHandler,+ defaultPluginDescriptor,+ mkPluginHandler)+import Language.LSP.Protocol.Message (Method (Method_TextDocumentSignatureHelp),+ SMethod (SMethod_TextDocumentSignatureHelp))+import Language.LSP.Protocol.Types (MarkupContent (MarkupContent),+ MarkupKind (MarkupKind_Markdown),+ Null (Null),+ ParameterInformation (ParameterInformation),+ Position (Position),+ SignatureHelp (..),+ SignatureHelpContext (..),+ SignatureHelpParams (SignatureHelpParams),+ SignatureInformation (..),+ TextDocumentIdentifier (TextDocumentIdentifier),+ UInt,+ type (|?) (InL, InR))++data Log++instance Pretty Log where+ pretty = \case {}++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor _recorder pluginId =+ (defaultPluginDescriptor pluginId "Provides signature help of something callable")+ { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider+ }++{- Note [Stale Results in Signature Help]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Stale results work well when users are reading code.++When we add support for writing code, such as automatically triggering signature+help when a space char is inserted, we probably have to use up-to-date results.+-}++{-+Here is a brief description of the algorithm of finding relevant bits from HIE AST+1. let 'hsAppNode' = the smallest 'HsApp' AST node which contains the cursor position+ See 'extractInfoFromSmallestContainingFunctionApplicationAst'+2. let 'functionNode' = the left-most node of 'hsAppNode'+ See 'getLeftMostNode'+3. try to get 'functionName' and 'functionTypes' from 'functionNode'+ We get 'Nothing' when we cannot get that info+ See 'getNodeNameAndTypes'+4. count 'parameterIndex' by traversing the 'hsAppNode' subtree from its root to the cursor position+ We get 'Nothing' when either the cursor position is at 'functionNode'+ or we encounter some AST node we do not yet know how to continue our traversal+ See 'getParameterIndex'+-}+signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp+signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken mSignatureHelpContext) = do+ nfp <- getNormalizedFilePathE uri+ results <- runIdeActionE "signatureHelp.ast" (shakeExtras ideState) $ do+ -- see Note [Stale Results in Signature Help]+ (HAR {hieAst, hieKind}, positionMapping) <- useWithStaleFastE GetHieAst nfp+ case fromCurrentPosition positionMapping position of+ Nothing -> pure []+ Just oldPosition -> do+ pure $+ extractInfoFromSmallestContainingFunctionApplicationAst+ oldPosition+ hieAst+ ( \span hieAst -> do+ let functionNode = getLeftMostNode hieAst+ (functionName, functionTypes) <- getNodeNameAndTypes hieKind functionNode+ parameterIndex <- getParameterIndex span hieAst+ Just (functionName, functionTypes, parameterIndex)+ )+ (docMap, argDocMap) <- runIdeActionE "signatureHelp.docMap" (shakeExtras ideState) $ do+ -- see Note [Stale Results in Signature Help]+ mResult <- ExceptT $ Right <$> useWithStaleFast GetDocMap nfp+ case mResult of+ Just (DKMap docMap _tyThingMap argDocMap, _positionMapping) -> pure (docMap, argDocMap)+ Nothing -> pure (mempty, mempty)+ case results of+ [(_functionName, [], _parameterIndex)] -> pure $ InR Null+ [(functionName, functionTypes, parameterIndex)] ->+ pure $ InL $ mkSignatureHelp mSignatureHelpContext docMap argDocMap (fromIntegral parameterIndex - 1) functionName functionTypes+ _ -> pure $ InR Null++mkSignatureHelp :: Maybe SignatureHelpContext -> DocMap -> ArgDocMap -> UInt -> Name -> [Type] -> SignatureHelp+mkSignatureHelp mSignatureHelpContext docMap argDocMap parameterIndex functionName functionTypes =+ SignatureHelp+ { _signatures = mkSignatureInformation docMap argDocMap parameterIndex functionName <$> functionTypes,+ _activeSignature = activeSignature,+ _activeParameter = Just $ InL parameterIndex+ }+ where+ activeSignature = case mSignatureHelpContext of+ Just+ ( SignatureHelpContext+ { _triggerKind,+ _triggerCharacter,+ _isRetrigger = True,+ _activeSignatureHelp = Just (SignatureHelp _signatures oldActivateSignature _activeParameter)+ }+ ) -> oldActivateSignature+ _ -> Just 0++mkSignatureInformation :: DocMap -> ArgDocMap -> UInt -> Name -> Type -> SignatureInformation+mkSignatureInformation docMap argDocMap parameterIndex functionName functionType =+ let functionNameLabelPrefix = printOutputableOneLine (ppr functionName) <> " :: "+ mFunctionDoc = case lookupNameEnv docMap functionName of+ Nothing -> Nothing+ Just spanDoc -> Just $ InR $ mkMarkdownDoc spanDoc+ thisArgDocMap = case lookupNameEnv argDocMap functionName of+ Nothing -> mempty+ Just thisArgDocMap' -> thisArgDocMap'+ in SignatureInformation+ { -- Server-side line wrapping may be better since more context is available.+ -- However, server-side line wrapping may make it harder to calculate+ -- parameter ranges. In addition, some clients, such as vscode, ignore+ -- server-side line wrapping and instead does client-side line wrapping.+ -- So we choose not to do server-side line wrapping.+ _label = functionNameLabelPrefix <> printOutputableOneLine functionType,+ _documentation = mFunctionDoc,+ _parameters = Just $ mkParameterInformations thisArgDocMap (fromIntegral $ T.length functionNameLabelPrefix) functionType,+ _activeParameter = Just $ InL parameterIndex+ }++mkParameterInformations :: IntMap SpanDoc -> UInt -> Type -> [ParameterInformation]+mkParameterInformations thisArgDocMap offset functionType =+ [ ParameterInformation (InR range) mParameterDoc+ | (parameterIndex, range) <- zip [0 ..] (bimap (+ offset) (+ offset) <$> findParameterRanges functionType),+ let mParameterDoc = case IntMap.lookup parameterIndex thisArgDocMap of+ Nothing -> Nothing+ Just spanDoc -> Just $ InR $ mkMarkdownDoc $ removeUris spanDoc+ ]+ where+ -- we already show uris in the function doc, no need to duplicate them in the parameter doc+ removeUris (SpanDocString docs _uris) = SpanDocString docs emptyUris+ removeUris (SpanDocText docs _uris) = SpanDocText docs emptyUris++ emptyUris = SpanDocUris Nothing Nothing++mkMarkdownDoc :: SpanDoc -> MarkupContent+mkMarkdownDoc = spanDocToMarkdown >>> T.unlines >>> MarkupContent MarkupKind_Markdown++findParameterRanges :: Type -> [(UInt, UInt)]+findParameterRanges functionType =+ let functionTypeString = printOutputableOneLine functionType+ functionTypeStringLength = fromIntegral $ T.length functionTypeString+ splitFunctionTypes = filter notTypeConstraint $ splitFunTysIgnoringForAll functionType+ splitFunctionTypeStrings = printOutputableOneLine . fst <$> splitFunctionTypes+ -- reverse to avoid matching "a" of "forall a" in "forall a. a -> a"+ reversedRanges =+ drop 1 $ -- do not need the range of the result (last) type+ findParameterStringRanges+ 0+ (T.reverse functionTypeString)+ (T.reverse <$> reverse splitFunctionTypeStrings)+ in reverse $ modifyRange functionTypeStringLength <$> reversedRanges+ where+ modifyRange functionTypeStringLength (start, end) =+ (functionTypeStringLength - end, functionTypeStringLength - start)++{-+The implemented method uses both structured type and unstructured type string.+It provides good enough results and is easier to implement than alternative+method 1 or 2.++Alternative method 1: use only structured type+This method is hard to implement because we need to duplicate some logic of 'ppr' for 'Type'.+Some tricky cases are as follows:+- 'Eq a => Num b -> c' is shown as '(Eq a, Numb) => c'+- 'forall' can appear anywhere in a type when RankNTypes is enabled+ f :: forall a. Maybe a -> forall b. (a, b) -> b+- '=>' can appear anywhere in a type+ g :: forall a b. Eq a => a -> Num b => b -> b+- ppr the first parameter type of '(a -> b) -> a -> b' is 'a -> b' (no parentheses)+- 'forall' is not always shown++Alternative method 2: use only unstructured type string+This method is hard to implement because we need to parse the type string.+Some tricky cases are as follows:+- h :: forall a (m :: Type -> Type). Monad m => a -> m a+-}+findParameterStringRanges :: UInt -> Text -> [Text] -> [(UInt, UInt)]+findParameterStringRanges _totalPrefixLength _functionTypeString [] = []+findParameterStringRanges totalPrefixLength functionTypeString (parameterTypeString : restParameterTypeStrings) =+ let (prefix, match) = T.breakOn parameterTypeString functionTypeString+ prefixLength = fromIntegral $ T.length prefix+ parameterTypeStringLength = fromIntegral $ T.length parameterTypeString+ start = totalPrefixLength + prefixLength+ in (start, start + parameterTypeStringLength)+ : findParameterStringRanges+ (totalPrefixLength + prefixLength + parameterTypeStringLength)+ (T.drop (fromIntegral parameterTypeStringLength) match)+ restParameterTypeStrings++-- similar to 'splitFunTys' but+-- 1) the result (last) type is included and+-- 2) toplevel foralls are ignored+splitFunTysIgnoringForAll :: Type -> [(Type, Maybe FunTyFlag)]+splitFunTysIgnoringForAll ty = case ty & dropForAlls & splitFunTy_maybe of+ Just (funTyFlag, _mult, parameterType, resultType) ->+ (parameterType, Just funTyFlag) : splitFunTysIgnoringForAll resultType+ Nothing -> [(ty, Nothing)]++notTypeConstraint :: (Type, Maybe FunTyFlag) -> Bool+notTypeConstraint (_type, Just FTF_T_T) = True+notTypeConstraint (_type, Nothing) = True+notTypeConstraint _ = False++extractInfoFromSmallestContainingFunctionApplicationAst ::+ Position -> HieASTs a -> (RealSrcSpan -> HieAST a -> Maybe b) -> [b]+extractInfoFromSmallestContainingFunctionApplicationAst position hieAsts extractInfo =+ M.elems $ flip M.mapMaybeWithKey (getAsts hieAsts) $ \hiePath hieAst ->+ smallestContainingSatisfying (positionToSpan hiePath position) (nodeHasAnnotation ("HsApp", "HsExpr")) hieAst+ >>= extractInfo (positionToSpan hiePath position)+ where+ positionToSpan hiePath position =+ let loc = mkLoc hiePath position in mkRealSrcSpan loc loc+ mkLoc (LexicalFastString hiePath) (Position line character) =+ mkRealSrcLoc hiePath (fromIntegral line + 1) (fromIntegral character + 1)++type Annotation = (FastStringCompat, FastStringCompat)++nodeHasAnnotation :: Annotation -> HieAST a -> Bool+nodeHasAnnotation annotation hieAst = case sourceNodeInfo hieAst of+ Nothing -> False+ Just nodeInfo -> isAnnotationInNodeInfo annotation nodeInfo++getLeftMostNode :: HieAST a -> HieAST a+getLeftMostNode thisNode =+ case nodeChildren thisNode of+ [] -> thisNode+ leftChild : _ -> getLeftMostNode leftChild++getNodeNameAndTypes :: HieKind a -> HieAST a -> Maybe (Name, [Type])+getNodeNameAndTypes hieKind hieAst =+ if nodeHasAnnotation ("HsVar", "HsExpr") hieAst+ then case hieAst & getSourceNodeIds & M.filter isUse & M.assocs of+ [(identifier, identifierDetails)] ->+ case extractName identifier of+ Nothing -> Nothing+ Just name ->+ let mTypeOfName = identType identifierDetails+ typesOfNode = case sourceNodeInfo hieAst of+ Nothing -> []+ Just nodeInfo -> nodeType nodeInfo+ allTypes = case mTypeOfName of+ Nothing -> typesOfNode+ -- (the last?) one type of 'typesOfNode' may (always?) be the same as 'typeOfName'+ -- To avoid generating two identical signature helps, we do a filtering here+ -- This is similar to 'dropEnd1' in Development.IDE.Spans.AtPoint.atPoint+ -- TODO perhaps extract a common function+ Just typeOfName -> typeOfName : filter (isDifferentType typeOfName) typesOfNode+ in Just (name, filterCoreTypes allTypes)+ [] -> Nothing+ _ -> Nothing -- seems impossible+ else Nothing+ where+ extractName = rightToMaybe++ isDifferentType type1 type2 = case hieKind of+ HieFresh -> deBruijnize type1 /= deBruijnize type2+ HieFromDisk {} -> type1 /= type2++ filterCoreTypes types = case hieKind of+ HieFresh -> types+ -- ignore this case since this only happens before we finish startup+ HieFromDisk {} -> []++isUse :: IdentifierDetails a -> Bool+isUse = identInfo >>> S.member Use++-- Just 1 means the first parameter+getParameterIndex :: RealSrcSpan -> HieAST a -> Maybe Integer+getParameterIndex span hieAst+ | nodeHasAnnotation ("HsApp", "HsExpr") hieAst =+ case nodeChildren hieAst of+ [leftChild, _] ->+ if span `isRealSubspanOf` nodeSpan leftChild+ then Nothing+ else getParameterIndex span leftChild >>= \parameterIndex -> Just (parameterIndex + 1)+ _ -> Nothing -- impossible+ | nodeHasAnnotation ("HsAppType", "HsExpr") hieAst =+ case nodeChildren hieAst of+ [leftChild, _] -> getParameterIndex span leftChild+ _ -> Nothing -- impossible+ | otherwise =+ case nodeChildren hieAst of+ [] -> Just 0 -- the function is found+ [child] -> getParameterIndex span child -- ignore irrelevant nodes+ _ -> Nothing
+ plugins/hls-signature-help-plugin/test/Main.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}++import Control.Arrow ((>>>))+import Control.Exception (throw)+import Control.Lens ((^.))+import Data.Maybe (fromJust)+import Data.Text (Text)+import qualified Data.Text as T+import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (PosPrefixInfo))+import Ide.Plugin.SignatureHelp (descriptor)+import qualified Language.LSP.Protocol.Lens as L+import Test.Hls+import Test.Hls.FileSystem (VirtualFileTree,+ directCradle, file,+ mkVirtualFileTree,+ text)++main :: IO ()+main =+ defaultTestRunner $+ testGroup+ "signatureHelp"+ [ mkTest+ "1 parameter"+ [__i|+ f :: Int -> Int+ f = _+ x = f 1+ ^^^^^^^^+ |]+ [ Nothing,+ Nothing,+ Nothing,+ Nothing,+ Nothing,+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "2 parameters"+ [__i|+ f :: Int -> Int -> Int+ f = _+ x = f 1 2+ ^ ^^^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1))+ ],+ mkTest+ "3 parameters"+ [__i|+ f :: Int -> Int -> Int -> Int+ f = _+ x = f 1 2 3+ ^ ^ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing, ParameterInformation (InR (19, 22)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing, ParameterInformation (InR (19, 22)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing, ParameterInformation (InR (19, 22)) Nothing]) (Just (InL 2))] (Just 0) (Just (InL 2))+ ],+ mkTest+ "parentheses"+ [__i|+ f :: Int -> Int -> Int+ f = _+ x = (f 1) 2+ ^^ ^^^^+ |]+ [ Nothing,+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1))+ ],+ mkTest+ "newline"+ [__i|+ f :: Int -> Int -> Int+ f = _+ x =+ (+ ^+ f+ ^+ 1+ ^+ )+ ^+ 2+ ^++ ^+ |]+ [ Nothing,+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)),+ Nothing+ ],+ mkTest+ "nested"+ [__i|+ f :: Int -> Int -> Int+ f = _+ g :: Int -> Int+ g = _+ x = f (g 1) 2+ ^^^^ ^^^^+ |]+ [ Nothing,+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "g :: Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "g :: Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1))+ ],+ mkTest+ "higher-order function"+ [__i|+ f :: (Int -> Int) -> Int -> Int+ f = _+ x = f (+ 1) 2+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: (Int -> Int) -> Int -> Int" Nothing (Just [ParameterInformation (InR (6, 16)) Nothing, ParameterInformation (InR (21, 24)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "type constraint"+ [__i|+ f :: (Num a) => a -> a -> a+ f = _+ x = f 1 2+ ^ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. Num a => a -> a -> a" Nothing (Just [ParameterInformation (InR (24, 25)) Nothing, ParameterInformation (InR (29, 30)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (16, 23)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. Num a => a -> a -> a" Nothing (Just [ParameterInformation (InR (24, 25)) Nothing, ParameterInformation (InR (29, 30)) Nothing]) (Just (InL 1)), SignatureInformation "f :: Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (16, 23)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1))+ ],+ mkTest+ "type constraint with kind signatures"+ [__i|+ x :: IO Bool+ x = pure True+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "pure :: forall (f :: Type -> Type) a. Applicative f => a -> f a" (Just $ InR $ MarkupContent MarkupKind_Markdown "Lift a value") (Just [ParameterInformation (InR (55, 56)) Nothing]) (Just (InL 0)), SignatureInformation "pure :: Bool -> IO Bool" (Just $ InR $ MarkupContent MarkupKind_Markdown "Lift a value") (Just [ParameterInformation (InR (8, 12)) Nothing]) (Just (InL 0)), SignatureInformation "pure :: forall a. a -> IO a" (Just $ InR $ MarkupContent MarkupKind_Markdown "Lift a value") (Just [ParameterInformation (InR (18, 19)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "2 type constraints"+ [__i|+ f :: forall a. (Eq a, Num a) => a -> a -> a+ f = _+ x = f True+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. (Eq a, Num a) => a -> a -> a" Nothing (Just [ParameterInformation (InR (32, 33)) Nothing, ParameterInformation (InR (37, 38)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Bool -> Bool -> Bool" Nothing (Just [ParameterInformation (InR (5, 9)) Nothing, ParameterInformation (InR (13, 17)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "dynamic function"+ [__i|+ f :: Int -> Int -> Int+ f = _+ g :: Int -> Int -> Int+ g = _+ x = (if _ then f else g) 1 2+ ^^ ^^^ ^ ^^^ ^ ^^^^^^^^+ |]+ (replicate 18 Nothing),+ mkTest+ "very long type"+ [__i|+ f :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int+ f = _+ x = f 1+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5, 8)) Nothing, ParameterInformation (InR (12, 15)) Nothing, ParameterInformation (InR (19, 22)) Nothing, ParameterInformation (InR (26, 29)) Nothing, ParameterInformation (InR (33, 36)) Nothing, ParameterInformation (InR (40, 43)) Nothing, ParameterInformation (InR (47, 50)) Nothing, ParameterInformation (InR (54, 57)) Nothing, ParameterInformation (InR (61, 64)) Nothing, ParameterInformation (InR (68, 71)) Nothing, ParameterInformation (InR (75, 78)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "very long type with type constraint"+ [__i|+ f :: Num abcdefghijklmn => abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn+ f = _+ x = f 1+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall abcdefghijklmn. Num abcdefghijklmn => abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn" Nothing (Just [ParameterInformation (InR (50, 64)) Nothing, ParameterInformation (InR (68, 82)) Nothing, ParameterInformation (InR (86, 100)) Nothing, ParameterInformation (InR (104, 118)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Integer -> Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (16, 23)) Nothing, ParameterInformation (InR (27, 34)) Nothing, ParameterInformation (InR (38, 45)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ -- TODO fix bug of wrong parameter range in the function type string+ -- https://github.com/haskell/haskell-language-server/pull/4626#discussion_r2261133076+ mkTestExpectFail+ "middle =>"+ [__i|+ f :: Eq a => a -> Num b => b -> b+ f = _+ x = f 1 True+ ^ ^ ^+ y = f True+ ^+ z = f 1+ ^+ |]+ ( BrokenIdeal+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Num Bool => Bool -> Bool" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (28, 32)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 1)), SignatureInformation "f :: Integer -> Num Bool => Bool -> Bool" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (28, 32)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Bool -> Num Integer => Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 9)) Nothing, ParameterInformation (InR (28, 35)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Num Integer => Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (31, 38)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ )+ ( BrokenCurrent+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Num Bool => Bool -> Bool" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (28, 32)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 1)), SignatureInformation "f :: Integer -> Num Bool => Bool -> Bool" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (28, 32)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Bool -> Num Integer => Integer -> Integer" Nothing (Just [ParameterInformation (InR (5, 9)) Nothing, ParameterInformation (InR (28, 35)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> Num b => b -> b" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (39, 40)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Num Integer => Integer -> Integer" Nothing (Just [ParameterInformation (InR (20, 27)) Nothing, ParameterInformation (InR (31, 38)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ ),+ mkTest+ "=> in parameter"+ [__i|+ f :: Eq a => a -> (Num b => b -> b) -> a+ f = _+ x = f 1+ ^ ^+ y = f 1 negate+ ^ ^+ |]+ ( let typ =+ if ghcVersion <= GHC98+ then "f :: Integer -> (Num Any => Any -> Any) -> Integer"+ else "f :: Integer -> (Num (ZonkAny 0) => ZonkAny 0 -> ZonkAny 0) -> Integer"+ range = if ghcVersion <= GHC98 then (17, 38) else (17, 58)+ in [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> (Num b => b -> b) -> a" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (31, 46)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> (Num b => b -> b) -> Integer" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (17, 32)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> (Num b => b -> b) -> a" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (31, 46)) Nothing]) (Just (InL 0)), SignatureInformation typ Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR range) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. Eq a => a -> (Num b => b -> b) -> a" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (31, 46)) Nothing]) (Just (InL 1)), SignatureInformation typ Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR range) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1))+ ]+ ),+ mkTest+ "RankNTypes(forall in middle)"+ [__i|+ f :: Maybe a -> forall b. (a, b) -> b+ f = _+ x1 = f Nothing+ ^ ^+ x2 = f (Just True)+ ^+ x3 = f Nothing (1, True)+ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. Maybe a -> forall b. (a, b) -> b" Nothing (Just [ParameterInformation (InR (15, 22)) Nothing, ParameterInformation (InR (36, 42)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Maybe a -> forall b. (a, b) -> b" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (26, 32)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. Maybe a -> forall b. (a, b) -> b" Nothing (Just [ParameterInformation (InR (15, 22)) Nothing, ParameterInformation (InR (36, 42)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Maybe Bool -> forall b. (Bool, b) -> b" Nothing (Just [ParameterInformation (InR (5, 15)) Nothing, ParameterInformation (InR (29, 38)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. Maybe a -> forall b. (a, b) -> b" Nothing (Just [ParameterInformation (InR (15, 22)) Nothing, ParameterInformation (InR (36, 42)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Maybe Integer -> forall b. (Integer, b) -> b" Nothing (Just [ParameterInformation (InR (5, 18)) Nothing, ParameterInformation (InR (32, 44)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ -- TODO fix bug of wrong parameter range in the function type string+ -- https://github.com/haskell/haskell-language-server/pull/4626#discussion_r2261133076+ mkTestExpectFail+ "RankNTypes(forall in middle), another"+ [__i|+ f :: l -> forall a. a -> a+ f = _+ x = f 1+ ^ ^+ |]+ ( BrokenIdeal+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall l. l -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (15, 16)) Nothing, ParameterInformation (InR (30, 31)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (26, 27)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ )+ ( BrokenCurrent+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall l. l -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (25, 26)) Nothing, ParameterInformation (InR (30, 31)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (26, 27)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ ),+ -- TODO fix bug of wrong parameter range in the function type string+ -- https://github.com/haskell/haskell-language-server/pull/4626#discussion_r2261133076+ mkTestExpectFail+ "RankNTypes(forall in middle), again"+ [__i|+ f :: a -> forall a. a -> a+ f = _+ x = f 1+ ^ ^+ |]+ ( BrokenIdeal+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. a -> forall a1. a1 -> a1" Nothing (Just [ParameterInformation (InR (15, 16)) Nothing, ParameterInformation (InR (31, 33)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (26, 27)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ )+ ( BrokenCurrent+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a. a -> forall a1. a1 -> a1" Nothing (Just [ParameterInformation (InR (27, 28)) Nothing, ParameterInformation (InR (31, 32)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> forall a. a -> a" Nothing (Just [ParameterInformation (InR (5, 12)) Nothing, ParameterInformation (InR (26, 27)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ ),+ mkTest+ "LinearTypes"+ [__i|+ {-\# LANGUAGE LinearTypes \#-}+ f :: (a -> b) %1 -> a -> b+ f = _+ x1 = f negate+ ^ ^+ x2 = f _ 1+ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. (a -> b) %1 -> a -> b" Nothing (Just [ParameterInformation (InR (18, 24)) Nothing, ParameterInformation (InR (32, 33)) Nothing]) (Just (InL 0)), SignatureInformation "f :: (Integer -> Integer) %1 -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (6, 24)) Nothing, ParameterInformation (InR (32, 39)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)),+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b. (a -> b) %1 -> a -> b" Nothing (Just [ParameterInformation (InR (18, 24)) Nothing, ParameterInformation (InR (32, 33)) Nothing]) (Just (InL 0)), SignatureInformation "f :: (Integer -> b) %1 -> Integer -> b" Nothing (Just [ParameterInformation (InR (6, 18)) Nothing, ParameterInformation (InR (26, 33)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "function documentation"+ [__i|+ -- |The 'f' function does something to a bool value.+ f :: Bool -> Bool+ f = _+ x = f True+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Bool -> Bool" (Just $ InR $ MarkupContent MarkupKind_Markdown "The `f` function does something to a bool value") (Just [ParameterInformation (InR (5, 9)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "function and parameters documentation"+ [__i|+ -- |Doc for function 'f'.+ f ::+ -- | The first 'Bool' parameter+ Bool ->+ -- | The second 'Int' parameter+ Int ->+ -- | The return value+ Bool+ f = _+ x = f True 1+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: Bool -> Int -> Bool" (Just $ InR $ MarkupContent MarkupKind_Markdown "Doc for function `f`") (Just [ParameterInformation (InR (5, 9)) (Just $ InR $ MarkupContent MarkupKind_Markdown "The first `Bool` parameter"), ParameterInformation (InR (13, 16)) (Just $ InR $ MarkupContent MarkupKind_Markdown "The second `Int` parameter")]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "imported function with no documentation"+ [__i|+ x = even 1+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "even :: forall a. Integral a => a -> Bool" (Just $ InR $ MarkupContent MarkupKind_Markdown "") (Just [ParameterInformation (InR (32, 33)) Nothing]) (Just (InL 0)), SignatureInformation "even :: Integer -> Bool" (Just $ InR $ MarkupContent MarkupKind_Markdown "") (Just [ParameterInformation (InR (8, 15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "imported function with parameter documentation"+ [__i|+ import Language.Haskell.TH.Lib (mkBytes)+ x = mkBytes _+ ^ ^+ |]+ [ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "mkBytes :: ForeignPtr Word8 -> Word -> Word -> Bytes" (Just $ InR $ MarkupContent MarkupKind_Markdown "Create a Bytes datatype representing raw bytes to be embedded into the") (Just [ParameterInformation (InR (11, 27)) (Just $ InR $ MarkupContent MarkupKind_Markdown "Pointer to the data"), ParameterInformation (InR (31, 35)) (Just $ InR $ MarkupContent MarkupKind_Markdown "Offset from the pointer"), ParameterInformation (InR (39, 43)) (Just $ InR $ MarkupContent MarkupKind_Markdown "Number of bytes")]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ],+ mkTest+ "TypeApplications"+ [__i|+ f :: a -> b -> c+ f = _+ x = f @Int @_ 1 True+ ^ ^ ^ ^+ |]+ [ Nothing,+ Nothing,+ Nothing,+ Just $ SimilarSignatureHelp $ SignatureHelp [SignatureInformation "f :: forall a b c. a -> b -> c" Nothing (Just [ParameterInformation (InR (19, 20)) Nothing, ParameterInformation (InR (24, 25)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))+ ]+ ]++mkTest :: TestName -> Text -> [Maybe SimilarSignatureHelp] -> TestTree+mkTest name sourceCode expectedSignatureHelps =+ parameterisedCursorTest+ name+ sourceCode+ expectedSignatureHelps+ getSignatureHelpFromSession++mkTestExpectFail ::+ TestName ->+ Text ->+ ExpectBroken 'Ideal [Maybe SimilarSignatureHelp] ->+ ExpectBroken 'Current [Maybe SimilarSignatureHelp] ->+ TestTree+mkTestExpectFail name sourceCode _idealSignatureHelps = unCurrent >>> mkTest name sourceCode++getSignatureHelpFromSession :: Text -> PosPrefixInfo -> IO (Maybe SimilarSignatureHelp)+getSignatureHelpFromSession sourceCode (PosPrefixInfo _ _ _ position) =+ let fileName = "A.hs"+ plugin = mkPluginTestDescriptor descriptor "signatureHelp"+ virtualFileTree = mkVirtualFileTreeWithSingleFile fileName sourceCode+ in runSessionWithServerInTmpDir def plugin virtualFileTree $ do+ doc <- openDoc fileName "haskell"+ (fmap . fmap) SimilarSignatureHelp (getSignatureHelp doc position)++mkVirtualFileTreeWithSingleFile :: FilePath -> Text -> VirtualFileTree+mkVirtualFileTreeWithSingleFile fileName sourceCode =+ let testDataDir = "/not-used-dir"+ in mkVirtualFileTree+ testDataDir+ [ directCradle [T.pack fileName],+ file fileName (text sourceCode)+ ]++newtype SimilarSignatureHelp = SimilarSignatureHelp SignatureHelp+ deriving newtype (Show)++-- custom Eq to ignore some details, such as added doc string+-- not symmetry+instance Eq SimilarSignatureHelp where+ SimilarSignatureHelp+ actualSignatureHelp@( SignatureHelp+ actualSignatureInformations+ actualActiveSignature+ actualActiveParameter+ )+ == SimilarSignatureHelp+ expectedSignatureHelp@( SignatureHelp+ expectedSignatureInformations+ expectedActiveSignature+ expectedActiveParameter+ )+ | actualSignatureHelp == expectedSignatureHelp = True+ | actualActiveSignature == expectedActiveSignature+ && actualActiveParameter == expectedActiveParameter =+ actualSignatureInformations ~= expectedSignatureInformations+ | otherwise = False++class IsSimilar a where+ (~=) :: a -> a -> Bool++instance IsSimilar SignatureInformation where+ actualSignatureInformation@( SignatureInformation+ actualLabel+ actualDocumentation+ actualParameters+ actualActiveParameter+ )+ ~= expectedSignatureInformation@( SignatureInformation+ expectedLabel+ expectedDocumentation+ expectedParameters+ expectedActiveParameter+ )+ | actualSignatureInformation == expectedSignatureInformation = True+ | actualLabel == expectedLabel && actualActiveParameter == expectedActiveParameter =+ actualDocumentation ~= expectedDocumentation+ && actualParameters ~= expectedParameters+ | otherwise = False++instance IsSimilar ParameterInformation where+ actualParameterInformation@(ParameterInformation actualLabel actualDocumentation)+ ~= expectedParameterInformation@(ParameterInformation expectedLabel expectedDocumentation)+ | actualParameterInformation == expectedParameterInformation = True+ | actualLabel == expectedLabel = actualDocumentation ~= expectedDocumentation+ | otherwise = False++instance IsSimilar MarkupContent where+ actualMarkupContent@(MarkupContent actualKind actualText)+ ~= expectedMarkupContent@(MarkupContent expectedKind expectedText)+ | actualMarkupContent == expectedMarkupContent = True+ | actualKind == expectedKind = actualText ~= expectedText+ | otherwise = False++instance IsSimilar Text where+ actualText ~= expectedText = expectedText `T.isInfixOf` actualText++instance (IsSimilar a) => IsSimilar [a] where+ [] ~= [] = True+ (x : xs) ~= (y : ys) = x ~= y && xs ~= ys+ _ ~= _ = False++instance (IsSimilar a) => IsSimilar (Maybe a) where+ Nothing ~= Nothing = True+ Just x ~= Just y = x ~= y+ _ ~= _ = False++instance (IsSimilar a, IsSimilar b) => IsSimilar (a |? b) where+ InL x ~= InL y = x ~= y+ InR x ~= InR y = x ~= y+ _ ~= _ = False++-- TODO use the one from lsp-test when we have https://github.com/haskell/lsp/pull/621++-- | Returns the signature help at the specified position.+getSignatureHelp :: TextDocumentIdentifier -> Position -> Session (Maybe SignatureHelp)+getSignatureHelp doc pos =+ let params = SignatureHelpParams doc pos Nothing Nothing+ in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentSignatureHelp params+ where+ getResponseResult rsp =+ case rsp ^. L.result of+ Right x -> x+ Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err
plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs view
@@ -38,14 +38,14 @@ mapMaybe) import qualified Data.Text as T import Development.IDE-import Development.IDE.Core.FileStore (getVersionedTextDoc)+import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import GHC.Exts-import qualified GHC.Runtime.Loader as Loader+import qualified GHC.Runtime.Loader as Loader import qualified GHC.Types.Error as Error import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Splice.Types@@ -58,9 +58,7 @@ import Data.Foldable (Foldable (foldl')) #endif -#if MIN_VERSION_ghc(9,4,1) import GHC.Data.Bag (Bag)-#endif #if MIN_VERSION_ghc(9,9,0) import GHC.Parser.Annotation (EpAnn (..))@@ -294,11 +292,9 @@ 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@@ -307,43 +303,24 @@ 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)+ matchSplice _ _ = Nothing 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@@ -418,14 +395,8 @@ 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) @@ -433,15 +404,12 @@ 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 ::@@ -458,11 +426,7 @@ 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@@ -510,12 +474,8 @@ (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 )
plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs view
@@ -2,7 +2,6 @@ {-# 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)@@ -14,6 +13,7 @@ import Development.IDE import Development.IDE.Core.Rules (getHieFile) import qualified Development.IDE.Core.Shake as Shake+import Development.IDE.GHC.Compat (HieFile (..)) import GHC.Generics (Generic) import Ide.Plugin.Config (PluginConfig (..)) import Ide.Types (PluginDescriptor (..), PluginId,
src/HlsPlugins.hs view
@@ -53,6 +53,10 @@ import qualified Ide.Plugin.Stan as Stan #endif +#if hls_signatureHelp+import qualified Ide.Plugin.SignatureHelp as SignatureHelp+#endif+ #if hls_moduleName import qualified Ide.Plugin.ModuleName as ModuleName #endif@@ -214,6 +218,9 @@ #if hls_stan let pId = "stan" in Stan.descriptor (pluginRecorder pId) pId : #endif+#if hls_signatureHelp+ let pId = "signatureHelp" in SignatureHelp.descriptor (pluginRecorder pId) pId:+#endif #if hls_splice Splice.descriptor "splice" : #endif@@ -224,7 +231,7 @@ let pId = "codeRange" in CodeRange.descriptor (pluginRecorder pId) pId: #endif #if hls_changeTypeSignature- ChangeTypeSignature.descriptor "changeTypeSignature" :+ let pId = "changeTypeSignature" in ChangeTypeSignature.descriptor (pluginRecorder pId) pId : #endif #if hls_gadt GADT.descriptor "gadt" :@@ -249,4 +256,3 @@ let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId : #endif GhcIde.descriptors (pluginRecorder "ghcide")-
src/Ide/Arguments.hs view
@@ -33,6 +33,7 @@ | BiosMode BiosAction | Ghcide GhcideArguments | VSCodeExtensionSchemaMode+ | PluginsCustomConfigMarkdownReferenceMode | DefaultConfigurationMode | PrintLibDir @@ -69,6 +70,7 @@ <|> hsubparser ( command "vscode-extension-schema" extensionSchemaCommand <> command "generate-default-config" generateDefaultConfigCommand+ <> command "plugins-custom-config-markdown-reference" pluginsCustomConfigMarkdownReferenceCommand ) <|> listPluginsParser <|> BiosMode <$> biosParser@@ -86,6 +88,9 @@ generateDefaultConfigCommand = info (pure DefaultConfigurationMode) (fullDesc <> progDesc "Print config supported by the server with default values")+ pluginsCustomConfigMarkdownReferenceCommand =+ info (pure PluginsCustomConfigMarkdownReferenceMode)+ (fullDesc <> progDesc "Print markdown reference for plugins custom config") printVersionParser :: String -> Parser PrintVersion printVersionParser exeName =
src/Ide/Main.hs view
@@ -15,6 +15,7 @@ import Data.List (sortOn) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.IO as T (putStrLn) import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT import Development.IDE.Core.Rules hiding (Log)@@ -28,7 +29,8 @@ import qualified HIE.Bios.Types as HieBios import Ide.Arguments import Ide.Logger as G-import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,+import Ide.Plugin.ConfigUtils (pluginsCustomConfigToMarkdownTables,+ pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, PluginId (PluginId), describePlugin, ipMap, pluginId)@@ -103,6 +105,8 @@ VSCodeExtensionSchemaMode -> do LT.putStrLn $ decodeUtf8 $ encodePrettySorted $ pluginsToVSCodeExtensionSchema idePlugins+ PluginsCustomConfigMarkdownReferenceMode -> do+ T.putStrLn $ pluginsCustomConfigToMarkdownTables idePlugins DefaultConfigurationMode -> do LT.putStrLn $ decodeUtf8 $ encodePrettySorted $ pluginsToDefaultConfig idePlugins PrintLibDir -> do
test/functional/ConfigSchema.hs view
@@ -31,6 +31,9 @@ , goldenGitDiff "generate-default-config" (defaultConfigFp ghcVersion) $ do stdout <- readProcess hlsExeCommand ["generate-default-config"] "" pure $ BS.pack stdout+ , goldenGitDiff "plugins-custom-config-markdown-reference" (markdownReferenceFp ghcVersion) $ do+ stdout <- readProcess hlsExeCommand ["plugins-custom-config-markdown-reference"] ""+ pure $ BS.pack stdout ] vscodeSchemaFp :: GhcVersion -> FilePath@@ -39,11 +42,17 @@ defaultConfigFp :: GhcVersion -> FilePath defaultConfigFp ghcVer = "test" </> "testdata" </> "schema" </> prettyGhcVersion ghcVer </> generateDefaultConfigJson +markdownReferenceFp :: GhcVersion -> FilePath+markdownReferenceFp ghcVer = "test" </> "testdata" </> "schema" </> prettyGhcVersion ghcVer </> markdownReferenceMd+ vscodeSchemaJson :: FilePath vscodeSchemaJson = "vscode-extension-schema.golden.json" generateDefaultConfigJson :: FilePath generateDefaultConfigJson = "default-config.golden.json"++markdownReferenceMd :: FilePath+markdownReferenceMd = "markdown-reference.md" prettyGhcVersion :: GhcVersion -> String prettyGhcVersion ghcVer = map toLower (show ghcVer)
− test/testdata/hieBiosError/hie.yaml
+ test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json view
@@ -0,0 +1,1 @@+{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs","pkg-name":"hieBiosMainIs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
+ test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json view
@@ -0,0 +1,1 @@+{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"missingModule-0.1.0.0-inplace","pkg-name":"missingModule","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json view
@@ -1,1 +1,1 @@-{"cabal-version":"3.10.1.0","cabal-lib-version":"3.10.1.0","compiler-id":"ghc-9.6.3","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.18.1.0","pkg-name":"base","pkg-version":"4.18.1.0","depends":["ghc-bignum-1.3","ghc-prim-0.10.0","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.10.0"]},{"type":"pre-existing","id":"ghc-prim-0.10.0","pkg-name":"ghc-prim","pkg-version":"0.10.0","depends":["rts-1.0.2"]},{"type":"configured","id":"noPrefixMatch-0.1.0.0-inplace-testExe","pkg-name":"noPrefixMatch","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server-dist/test/testdata/missingModuleTest/noPrefixMatch/."},"dist-dir":"/home/zubin/haskell-language-server-dist/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.6.3/noPrefixMatch-0.1.0.0/x/testExe","build-info":"/home/zubin/haskell-language-server-dist/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.6.3/noPrefixMatch-0.1.0.0/x/testExe/build-info.json","depends":["base-4.18.1.0"],"exe-depends":[],"component-name":"exe:testExe","bin-file":"/home/zubin/haskell-language-server-dist/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.6.3/noPrefixMatch-0.1.0.0/x/testExe/build/testExe/testExe"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}+{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"noPrefixMatch-0.1.0.0-inplace-testExe","pkg-name":"noPrefixMatch","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:testExe","bin-file":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build/testExe/testExe"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
test/testdata/schema/ghc910/default-config.golden.json view
@@ -91,6 +91,13 @@ }, "globalOn": true },+ "hlint": {+ "codeActionsOn": true,+ "config": {+ "flags": []+ },+ "diagnosticsOn": true+ }, "importLens": { "codeActionsOn": true, "codeLensOn": true,@@ -142,6 +149,9 @@ "variableToken": "variable" }, "globalOn": false+ },+ "signatureHelp": {+ "globalOn": true }, "stan": { "globalOn": false
test/testdata/schema/ghc910/vscode-extension-schema.golden.json view
@@ -213,6 +213,24 @@ "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",@@ -1016,6 +1034,12 @@ "haskell.plugin.semanticTokens.globalOn": { "default": false, "description": "Enables semanticTokens plugin",+ "scope": "resource",+ "type": "boolean"+ },+ "haskell.plugin.signatureHelp.globalOn": {+ "default": true,+ "description": "Enables signatureHelp plugin", "scope": "resource", "type": "boolean" },
test/testdata/schema/ghc912/default-config.golden.json view
@@ -149,6 +149,9 @@ "variableToken": "variable" }, "globalOn": false+ },+ "signatureHelp": {+ "globalOn": true } }, "sessionLoading": "singleComponent"
test/testdata/schema/ghc912/vscode-extension-schema.golden.json view
@@ -1036,5 +1036,11 @@ "description": "Enables semanticTokens plugin", "scope": "resource", "type": "boolean"+ },+ "haskell.plugin.signatureHelp.globalOn": {+ "default": true,+ "description": "Enables signatureHelp plugin",+ "scope": "resource",+ "type": "boolean" } }
− test/testdata/schema/ghc94/default-config.golden.json
@@ -1,164 +0,0 @@-{- "cabalFormattingProvider": "cabal-gild",- "checkParents": "CheckOnSave",- "checkProject": true,- "formattingProvider": "ormolu",- "maxCompletions": 40,- "plugin": {- "alternateNumberFormat": {- "globalOn": true- },- "cabal": {- "codeActionsOn": true,- "completionOn": true,- "diagnosticsOn": true,- "hoverOn": true,- "symbolsOn": true- },- "cabal-fmt": {- "config": {- "path": "cabal-fmt"- }- },- "cabal-gild": {- "config": {- "path": "cabal-gild"- }- },- "cabalHaskellIntegration": {- "globalOn": true- },- "callHierarchy": {- "globalOn": true- },- "changeTypeSignature": {- "globalOn": true- },- "class": {- "codeActionsOn": true,- "codeLensOn": true- },- "eval": {- "codeActionsOn": true,- "codeLensOn": true,- "config": {- "diff": true,- "exception": false- }- },- "explicit-fields": {- "codeActionsOn": true,- "inlayHintsOn": 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,- "inlayHintsOn": 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- }- },- "sessionLoading": "singleComponent"-}
− test/testdata/schema/ghc94/vscode-extension-schema.golden.json
@@ -1,1058 +0,0 @@-{- "haskell.plugin.alternateNumberFormat.globalOn": {- "default": true,- "description": "Enables alternateNumberFormat plugin",- "scope": "resource",- "type": "boolean"- },- "haskell.plugin.cabal-fmt.config.path": {- "default": "cabal-fmt",- "markdownDescription": "Set path to 'cabal-fmt' executable",- "scope": "resource",- "type": "string"- },- "haskell.plugin.cabal-gild.config.path": {- "default": "cabal-gild",- "markdownDescription": "Set path to 'cabal-gild' executable",- "scope": "resource",- "type": "string"- },- "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.cabal.hoverOn": {- "default": true,- "description": "Enables cabal hover",- "scope": "resource",- "type": "boolean"- },- "haskell.plugin.cabal.symbolsOn": {- "default": true,- "description": "Enables cabal symbols",- "scope": "resource",- "type": "boolean"- },- "haskell.plugin.cabalHaskellIntegration.globalOn": {- "default": true,- "description": "Enables cabalHaskellIntegration plugin",- "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.codeActionsOn": {- "default": true,- "description": "Enables eval code actions",- "scope": "resource",- "type": "boolean"- },- "haskell.plugin.eval.codeLensOn": {- "default": true,- "description": "Enables eval 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.explicit-fields.codeActionsOn": {- "default": true,- "description": "Enables explicit-fields code actions",- "scope": "resource",- "type": "boolean"- },- "haskell.plugin.explicit-fields.inlayHintsOn": {- "default": true,- "description": "Enables explicit-fields inlay hints",- "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.importLens.inlayHintsOn": {- "default": true,- "description": "Enables importLens inlay hints",- "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
@@ -153,6 +153,9 @@ }, "globalOn": false },+ "signatureHelp": {+ "globalOn": true+ }, "splice": { "globalOn": true },
test/testdata/schema/ghc96/vscode-extension-schema.golden.json view
@@ -1043,6 +1043,12 @@ "scope": "resource", "type": "boolean" },+ "haskell.plugin.signatureHelp.globalOn": {+ "default": true,+ "description": "Enables signatureHelp plugin",+ "scope": "resource",+ "type": "boolean"+ }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin",
test/testdata/schema/ghc98/default-config.golden.json view
@@ -153,6 +153,9 @@ }, "globalOn": false },+ "signatureHelp": {+ "globalOn": true+ }, "splice": { "globalOn": true },
test/testdata/schema/ghc98/vscode-extension-schema.golden.json view
@@ -1043,6 +1043,12 @@ "scope": "resource", "type": "boolean" },+ "haskell.plugin.signatureHelp.globalOn": {+ "default": true,+ "description": "Enables signatureHelp plugin",+ "scope": "resource",+ "type": "boolean"+ }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin",
− test/testdata/wErrorTest/dist-newstyle/cache/plan.json
@@ -1,1 +0,0 @@-{"cabal-version":"3.8.1.0","cabal-lib-version":"3.8.1.0","compiler-id":"ghc-9.2.4","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.16.3.0","pkg-name":"base","pkg-version":"4.16.3.0","depends":["ghc-bignum-1.2","ghc-prim-0.8.0","rts"]},{"type":"pre-existing","id":"ghc-bignum-1.2","pkg-name":"ghc-bignum","pkg-version":"1.2","depends":["ghc-prim-0.8.0"]},{"type":"pre-existing","id":"ghc-prim-0.8.0","pkg-name":"ghc-prim","pkg-version":"0.8.0","depends":["rts"]},{"type":"pre-existing","id":"rts","pkg-name":"rts","pkg-version":"1.0.2","depends":[]},{"type":"configured","id":"test-0.1.0.0-inplace","pkg-name":"test","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server-dist/test/testdata/wErrorTest/."},"dist-dir":"/home/zubin/haskell-language-server-dist/test/testdata/wErrorTest/dist-newstyle/build/x86_64-linux/ghc-9.2.4/test-0.1.0.0","build-info":"/home/zubin/haskell-language-server-dist/test/testdata/wErrorTest/dist-newstyle/build/x86_64-linux/ghc-9.2.4/test-0.1.0.0/build-info.json","depends":["base-4.16.3.0"],"exe-depends":[],"component-name":"lib"}]}