diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,187 @@ # Changelog for haskell-language-server +## 2.7.0.0 + +- Bindists for GHC 9.8.2 + - Enable many more plugins, making GHC 9.8.2 fully supported +- Fix refactor code actions for vim +- Preserve HLint's diagnostic severity +- Many other bug fixes. + +### Pull Requests + +- Enable pedantic for remaining plugins + ([#4091](https://github.com/haskell/haskell-language-server/pull/4091)) by @jhrcek +- Add support for fourmolu 0.15 + ([#4086](https://github.com/haskell/haskell-language-server/pull/4086)) by @brandonchinn178 +- refactor plugin: fix regex for extracting import suggestions + ([#4080](https://github.com/haskell/haskell-language-server/pull/4080)) by @jhrcek +- Bump to hiedb 0.6.0.0 + ([#4077](https://github.com/haskell/haskell-language-server/pull/4077)) by @jhrcek +- ghcide: Only try `stat`ing a core file after we ensure it actually exists + ([#4076](https://github.com/haskell/haskell-language-server/pull/4076)) by @wz1000 +- Fix small typo in Retrie error message + ([#4075](https://github.com/haskell/haskell-language-server/pull/4075)) by @iustin +- add Method_TextDocumentSemanticTokensFullDelta + ([#4073](https://github.com/haskell/haskell-language-server/pull/4073)) by @soulomoon +- Fix -Wall in retrie plugin + ([#4071](https://github.com/haskell/haskell-language-server/pull/4071)) by @jhrcek +- Fix -Wall in qualified imported names plugin + ([#4070](https://github.com/haskell/haskell-language-server/pull/4070)) by @jhrcek +- benchmarks: switch from deprecated haskell/actions/setup to haskell-actions/setup + ([#4068](https://github.com/haskell/haskell-language-server/pull/4068)) by @jhrcek +- Bump pre-commit/action from 3.0.0 to 3.0.1 + ([#4066](https://github.com/haskell/haskell-language-server/pull/4066)) by @dependabot[bot] +- Fix -Wall in refactor plugin + ([#4065](https://github.com/haskell/haskell-language-server/pull/4065)) by @jhrcek +- Redundant imports/exports: use range only to determine which code actions are in scope + ([#4063](https://github.com/haskell/haskell-language-server/pull/4063)) by @keithfancher +- Bump haskell-actions/setup to get GHC 9.6.4 in CI + ([#4062](https://github.com/haskell/haskell-language-server/pull/4062)) by @jhrcek +- Enable pedantic for more components + ([#4061](https://github.com/haskell/haskell-language-server/pull/4061)) by @jhrcek +- stack CI: switch to offic. haskell images, bump to lts-22.9 (ghc 9.6.4) + ([#4060](https://github.com/haskell/haskell-language-server/pull/4060)) by @jhrcek +- Improve hls class plugin test + ([#4059](https://github.com/haskell/haskell-language-server/pull/4059)) by @soulomoon +- Bump ghcide-test-utils to 2.0.0.0 + ([#4058](https://github.com/haskell/haskell-language-server/pull/4058)) by @wz1000 +- Promote more warnings to errors in ghcide + ([#4054](https://github.com/haskell/haskell-language-server/pull/4054)) by @jhrcek +- Add -Wunused-packages to common warnings + ([#4053](https://github.com/haskell/haskell-language-server/pull/4053)) by @jhrcek +- Bump lsp versions + ([#4052](https://github.com/haskell/haskell-language-server/pull/4052)) by @michaelpj +- Optimize semantic token extraction logic + ([#4050](https://github.com/haskell/haskell-language-server/pull/4050)) by @soulomoon +- Fix warnings in hls-graph, enable pedantic in CI + ([#4047](https://github.com/haskell/haskell-language-server/pull/4047)) by @jhrcek +- Fix -Wredundant-constraints + ([#4044](https://github.com/haskell/haskell-language-server/pull/4044)) by @jhrcek +- Disable caching job with ghc 9.2 on windows + ([#4043](https://github.com/haskell/haskell-language-server/pull/4043)) by @jhrcek +- fix token omitting problem if multiple tokens are connected. + ([#4041](https://github.com/haskell/haskell-language-server/pull/4041)) by @soulomoon +- Set test options via cabal.project + ([#4039](https://github.com/haskell/haskell-language-server/pull/4039)) by @michaelpj +- Fix document version test in hls-class-plugin + ([#4038](https://github.com/haskell/haskell-language-server/pull/4038)) by @July541 +- Fix -Wunused-imports + ([#4037](https://github.com/haskell/haskell-language-server/pull/4037)) by @jhrcek +- Use GHC2021 + ([#4033](https://github.com/haskell/haskell-language-server/pull/4033)) by @michaelpj +- Remove ghcide-test-utils as a separate package + ([#4032](https://github.com/haskell/haskell-language-server/pull/4032)) by @michaelpj +- Fix weird behavior of OPTIONS_GHC completions (fixes #3908) + ([#4031](https://github.com/haskell/haskell-language-server/pull/4031)) by @jhrcek +- semantic tokens: add infix operator + ([#4030](https://github.com/haskell/haskell-language-server/pull/4030)) by @soulomoon +- fix: a typo in docs/configuration.md + ([#4029](https://github.com/haskell/haskell-language-server/pull/4029)) by @kkweon +- Turn off tasty-rerun + ([#4028](https://github.com/haskell/haskell-language-server/pull/4028)) by @michaelpj +- Reduce the number of ad-hoc helper test functions in refactor plugin tests + ([#4027](https://github.com/haskell/haskell-language-server/pull/4027)) by @jhrcek +- Fix documentation/image links + ([#4025](https://github.com/haskell/haskell-language-server/pull/4025)) by @jhrcek +- Fix various issues + ([#4024](https://github.com/haskell/haskell-language-server/pull/4024)) by @michaelpj +- Use relative file paths for HIE files and Stan's config maps + ([#4023](https://github.com/haskell/haskell-language-server/pull/4023)) by @keithfancher +- fix isClassNodeIdentifier in hls-class-plugin + ([#4020](https://github.com/haskell/haskell-language-server/pull/4020)) by @soulomoon +- Fix -Wall and -Wunused-packages in hlint plugin + ([#4019](https://github.com/haskell/haskell-language-server/pull/4019)) by @jhrcek +- update hlint to 3.8 and prevent linting on testdata dir + ([#4018](https://github.com/haskell/haskell-language-server/pull/4018)) by @soulomoon +- refactor plugin: add reproducer and fix for #3795 + ([#4016](https://github.com/haskell/haskell-language-server/pull/4016)) by @jhrcek +- Fix -Wall and -Wunused-packages in stylish-haskell plugin + ([#4015](https://github.com/haskell/haskell-language-server/pull/4015)) by @jhrcek +- Fix -Wall and -Wunused-packages in stan plugin + ([#4014](https://github.com/haskell/haskell-language-server/pull/4014)) by @jhrcek +- fix doc for semantic token + ([#4011](https://github.com/haskell/haskell-language-server/pull/4011)) by @soulomoon +- Fix -Wall and -Wunused-packages in module name and overloaded record dot plugins + ([#4009](https://github.com/haskell/haskell-language-server/pull/4009)) by @jhrcek +- Fix -Wall and -Wunused-package in gadt plugin + ([#4008](https://github.com/haskell/haskell-language-server/pull/4008)) by @jhrcek +- Fix -Wall and -Wunused-packages in fourmolu and ormolu plugins + ([#4007](https://github.com/haskell/haskell-language-server/pull/4007)) by @jhrcek +- Fix -Wall and -Wunused-packages in plugins api and floskell + ([#4005](https://github.com/haskell/haskell-language-server/pull/4005)) by @jhrcek +- Fix -Wunused-packages in test utils + ([#4004](https://github.com/haskell/haskell-language-server/pull/4004)) by @jhrcek +- Update base lower bounds for HLS + ([#4000](https://github.com/haskell/haskell-language-server/pull/4000)) by @fendor +- Various 9.8 compat + ([#3998](https://github.com/haskell/haskell-language-server/pull/3998)) by @michaelpj +- Fix -Wall and -Wunused-packages in explicit-record-fields plugin + ([#3996](https://github.com/haskell/haskell-language-server/pull/3996)) by @jhrcek +- Fix -Wall and -Wunused-packages in explicit fixity plugin + ([#3995](https://github.com/haskell/haskell-language-server/pull/3995)) by @jhrcek +- Remove an allow-newer + ([#3989](https://github.com/haskell/haskell-language-server/pull/3989)) by @michaelpj +- chore: Fix typo s/occured/occurred + ([#3988](https://github.com/haskell/haskell-language-server/pull/3988)) by @hugo-syn +- Update support tables + ([#3987](https://github.com/haskell/haskell-language-server/pull/3987)) by @michaelpj +- Fix most -Wall in ghcide + ([#3984](https://github.com/haskell/haskell-language-server/pull/3984)) by @jhrcek +- Fix -Wall and -Wunused-packages in pragmas plugin + ([#3982](https://github.com/haskell/haskell-language-server/pull/3982)) by @jhrcek +- Fix -Wall and -Wunused-packages in eval plugin + ([#3981](https://github.com/haskell/haskell-language-server/pull/3981)) by @jhrcek +- Fix -Wall and -Wunused-packages in code-range plugin + ([#3980](https://github.com/haskell/haskell-language-server/pull/3980)) by @jhrcek +- Fix -Wall, -Wunused-packages and hlint warnings in call-hierarchy plugin + ([#3979](https://github.com/haskell/haskell-language-server/pull/3979)) by @jhrcek +- Fix -Wunused-packages in hls-cabal-plugin + ([#3977](https://github.com/haskell/haskell-language-server/pull/3977)) by @jhrcek +- Merge plugins into the HLS package + ([#3976](https://github.com/haskell/haskell-language-server/pull/3976)) by @michaelpj +- Fix most hlint warnings in ghcide + ([#3975](https://github.com/haskell/haskell-language-server/pull/3975)) by @jhrcek +- Remove allow-newer for ghc-trace-events + ([#3974](https://github.com/haskell/haskell-language-server/pull/3974)) by @jhrcek +- Exactprint plugins for 9.8 + ([#3973](https://github.com/haskell/haskell-language-server/pull/3973)) by @wz1000 +- Fix -Wall and -Wunused-packages in hls-class-plugin + ([#3972](https://github.com/haskell/haskell-language-server/pull/3972)) by @jhrcek +- Document cabal diagnostic options + ([#3971](https://github.com/haskell/haskell-language-server/pull/3971)) by @fendor +- Fix -Wall and -Wunused-packages in change-type-signature plugin + ([#3970](https://github.com/haskell/haskell-language-server/pull/3970)) by @jhrcek +- Semantic tokens: expand type synonym to checkout forall function type when possible + ([#3967](https://github.com/haskell/haskell-language-server/pull/3967)) by @soulomoon +- Fix -Wunused-packages in hls-cabal-fmt-plugin + ([#3965](https://github.com/haskell/haskell-language-server/pull/3965)) by @jhrcek +- Fix -Wall and -Wunused-packages in hls-alternate-number-format-plugin + ([#3964](https://github.com/haskell/haskell-language-server/pull/3964)) by @jhrcek +- Prepare release 2.6.0.0 + ([#3959](https://github.com/haskell/haskell-language-server/pull/3959)) by @wz1000 +- Semantic tokens: add module name support and improve performance and accuracy by traversing the hieAst along with source code + ([#3958](https://github.com/haskell/haskell-language-server/pull/3958)) by @soulomoon +- Bump cachix/cachix-action from 13 to 14 + ([#3956](https://github.com/haskell/haskell-language-server/pull/3956)) by @dependabot[bot] +- Bump cachix/install-nix-action from 24 to 25 + ([#3955](https://github.com/haskell/haskell-language-server/pull/3955)) by @dependabot[bot] +- Remove unused dependencies in hls-refactor-plugin + ([#3953](https://github.com/haskell/haskell-language-server/pull/3953)) by @jhrcek +- Cleanup conditional build logic pertaining to pre 9.2 GHCs + ([#3948](https://github.com/haskell/haskell-language-server/pull/3948)) by @jhrcek +- Fix issue: HLS HLint plugin doesn't preserve HLint's severities #3881 + ([#3902](https://github.com/haskell/haskell-language-server/pull/3902)) by @IAmPara0x +- Don't run hlint on testdata directories + ([#3901](https://github.com/haskell/haskell-language-server/pull/3901)) by @fendor +- Add option for setting manual path to Fourmolu binary + ([#3860](https://github.com/haskell/haskell-language-server/pull/3860)) by @georgefst + ## 2.6.0.0 - Bindists for GHC 9.6.4 - A new semantic tokens plugin (#3892, @soulomoon). -- Improvements to multiple home unit support with GHC 9.4. Using cabal 3.11+ will +- Improvements to multiple home unit support with GHC 9.4. When HLS is used with cabal 3.11+ it will load proper multiple home unit sessions by default, fixing a lot of issues with loading and reloading projects that have more than one component (#3462, @wz1000). - Removed implicit-hie, resulting in better behaviour for projects without cradles. @@ -15,7 +192,7 @@ - fix: semantic token omitting record field in `{-# LANGUAGE DuplicateRecordFields #-}` #3950 ([#3951](https://github.com/haskell/haskell-language-server/pull/3951)) by @soulomoon -- Properties API: Remove unsafe coerce in favor of type class based method in +- Properties API: Remove unsafe coerce in favor of type class based method in ([#3947](https://github.com/haskell/haskell-language-server/pull/3947)) by @soulomoon - Bump to hiedb 0.5.0.0 to fix #3542 ([#3943](https://github.com/haskell/haskell-language-server/pull/3943)) by @wz1000 @@ -51,7 +228,7 @@ ([#3913](https://github.com/haskell/haskell-language-server/pull/3913)) by @michaelpj - Update ghc-version-support.md for 2.5.0 ([#3909](https://github.com/haskell/haskell-language-server/pull/3909)) by @lehmacdj -- Give plugins descriptions, include versions of key dependencies +- Give plugins descriptions, include versions of key dependencies ([#3903](https://github.com/haskell/haskell-language-server/pull/3903)) by @michaelpj - Remove some buildability blockers that aren't needed ([#3899](https://github.com/haskell/haskell-language-server/pull/3899)) by @michaelpj diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,9 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main(main) where import Control.Exception (displayException) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,640 +1,1865 @@ -cabal-version: 3.0 -category: Development -name: haskell-language-server -version: 2.6.0.0 -synopsis: LSP server for GHC -description: - Please see the README on GitHub at - -homepage: https://github.com/haskell/haskell-language-server#readme -bug-reports: https://github.com/haskell/haskell-language-server/issues -author: The Haskell IDE Team -maintainer: alan.zimm@gmail.com -copyright: The Haskell IDE Team -license: Apache-2.0 -license-file: LICENSE -build-type: Simple -tested-with: GHC == 9.0.2 || ==9.2.5 -extra-source-files: - README.md - ChangeLog.md - test/testdata/**/*.project - test/testdata/**/*.cabal - test/testdata/**/*.yaml - test/testdata/**/*.hs - bindist/wrapper.in - -flag pedantic - description: Enable -Werror - default: False - manual: True - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server - -common common-deps - build-depends: - , base >=4.12 && <5 - , directory - , extra - , filepath - , text - , prettyprinter >= 1.7 - --- Default warnings in HLS -common warnings - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors - --- Allow compiling in pedantic mode -common pedantic - if flag(pedantic) - ghc-options: -Werror - --- Plugin flags are designed for 'cabal install haskell-language-server': --- - Bulk flags should be default:False --- - Individual flags should be default:True - --- The intent of this flag is being able to keep the ghc condition for hackage --- but skip it via flags in cabal.project as plugins for new ghcs usually --- are buildable using cabal.project tweaks -flag ignore-plugins-ghc-bounds - description: Force the inclusion of plugins even if they are not buildable by default with a specific ghc version - default: False - manual: True - - -flag cabal - description: Enable cabal plugin - default: True - manual: True - -flag class - description: Enable class plugin - default: True - manual: True - -flag callHierarchy - description: Enable call hierarchy plugin - default: True - manual: True - -flag eval - description: Enable eval plugin - default: True - manual: True - -flag importLens - description: Enable importLens plugin - default: True - manual: True - -flag rename - description: Enable rename plugin - default: True - manual: True - -flag retrie - description: Enable retrie plugin - default: True - manual: True - -flag hlint - description: Enable hlint plugin - default: True - manual: True - -flag stan - description: Enable stan plugin - default: True - manual: True - -flag moduleName - description: Enable moduleName plugin - default: True - manual: True - -flag pragmas - description: Enable pragmas plugin - default: True - manual: True - -flag splice - description: Enable splice plugin - default: True - manual: True - -flag alternateNumberFormat - description: Enable Alternate Number Format plugin - default: True - manual: True - -flag qualifyImportedNames - description: Enable qualifyImportedNames plugin - default: True - manual: True - -flag codeRange - description: Enable Code Range plugin - default: True - manual: True - -flag changeTypeSignature - description: Enable changeTypeSignature plugin - default: True - manual: True - -flag gadt - description: Enable gadt plugin - default: True - manual: True - -flag explicitFixity - description: Enable explicitFixity plugin - default: True - manual: True - -flag explicitFields - description: Enable explicitFields plugin - default: True - manual: True - -flag overloadedRecordDot - description: Enable overloadedRecordDot plugin - default: True - manual: True - -flag semanticTokens - description: Enable semantic tokens plugin - default: True - manual: True - --- formatters - -flag floskell - description: Enable floskell plugin - default: True - manual: True - -flag fourmolu - description: Enable fourmolu plugin - default: True - manual: True - -flag ormolu - description: Enable ormolu plugin - default: True - manual: True - -flag stylishHaskell - description: Enable stylishHaskell plugin - default: True - manual: True - -flag refactor - description: Enable refactor plugin - default: True - manual: True - -flag dynamic - description: Build with the dyn rts - default: True - manual: True - -flag cabalfmt - description: Enable cabal-fmt plugin - default: True - manual: True - -common cabalfmt - if flag(cabalfmt) - build-depends: hls-cabal-fmt-plugin == 2.6.0.0 - cpp-options: -Dhls_cabalfmt - -common cabal - if flag(cabal) - build-depends: hls-cabal-plugin == 2.6.0.0 - cpp-options: -Dhls_cabal - -common class - if flag(class) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-class-plugin == 2.6.0.0 - cpp-options: -Dhls_class - -common callHierarchy - if flag(callHierarchy) - build-depends: hls-call-hierarchy-plugin == 2.6.0.0 - cpp-options: -Dhls_callHierarchy - -common eval - if flag(eval) - build-depends: hls-eval-plugin == 2.6.0.0 - cpp-options: -Dhls_eval - -common importLens - if flag(importLens) - build-depends: hls-explicit-imports-plugin == 2.6.0.0 - cpp-options: -Dhls_importLens - -common rename - if flag(rename) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-rename-plugin == 2.6.0.0 - cpp-options: -Dhls_rename - -common retrie - if flag(retrie) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-retrie-plugin == 2.6.0.0 - cpp-options: -Dhls_retrie - -common hlint - if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-hlint-plugin == 2.6.0.0 - cpp-options: -Dhls_hlint - -common stan - if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) - build-depends: hls-stan-plugin == 2.6.0.0 - cpp-options: -Dhls_stan - -common moduleName - if flag(moduleName) - build-depends: hls-module-name-plugin == 2.6.0.0 - cpp-options: -Dhls_moduleName - -common pragmas - if flag(pragmas) - build-depends: hls-pragmas-plugin == 2.6.0.0 - cpp-options: -Dhls_pragmas - -common splice - if flag(splice) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-splice-plugin == 2.6.0.0 - cpp-options: -Dhls_splice - -common alternateNumberFormat - if flag(alternateNumberFormat) - build-depends: hls-alternate-number-format-plugin == 2.6.0.0 - cpp-options: -Dhls_alternateNumberFormat - -common qualifyImportedNames - if flag(qualifyImportedNames) - build-depends: hls-qualify-imported-names-plugin == 2.6.0.0 - cpp-options: -Dhls_qualifyImportedNames - -common codeRange - if flag(codeRange) - build-depends: hls-code-range-plugin == 2.6.0.0 - cpp-options: -Dhls_codeRange - -common changeTypeSignature - if flag(changeTypeSignature) - build-depends: hls-change-type-signature-plugin == 2.6.0.0 - cpp-options: -Dhls_changeTypeSignature - -common gadt - if flag(gadt) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-gadt-plugin == 2.6.0.0 - cpp-options: -Dhls_gadt - -common explicitFixity - if flag(explicitFixity) - build-depends: hls-explicit-fixity-plugin == 2.6.0.0 - cpp-options: -DexplicitFixity - -common explicitFields - if flag(explicitFields) - build-depends: hls-explicit-record-fields-plugin == 2.6.0.0 - cpp-options: -DexplicitFields - -common overloadedRecordDot - if flag(overloadedRecordDot) && (impl(ghc >= 9.2.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-overloaded-record-dot-plugin == 2.6.0.0 - cpp-options: -Dhls_overloaded_record_dot - --- formatters - -common floskell - if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-floskell-plugin == 2.6.0.0 - cpp-options: -Dhls_floskell - -common fourmolu - if flag(fourmolu) - build-depends: hls-fourmolu-plugin == 2.6.0.0 - cpp-options: -Dhls_fourmolu - -common ormolu - if flag(ormolu) - build-depends: hls-ormolu-plugin == 2.6.0.0 - cpp-options: -Dhls_ormolu - -common stylishHaskell - if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-stylish-haskell-plugin == 2.6.0.0 - cpp-options: -Dhls_stylishHaskell - -common refactor - if flag(refactor) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-refactor-plugin == 2.6.0.0 - cpp-options: -Dhls_refactor - -common semanticTokens - if flag(semanticTokens) - build-depends: hls-semantic-tokens-plugin == 2.6.0.0 - cpp-options: -Dhls_semanticTokens - - -library - import: common-deps - -- configuration - , warnings - , pedantic - -- plugins - , cabal - , callHierarchy - , cabalfmt - , changeTypeSignature - , class - , eval - , importLens - , rename - , retrie - , hlint - , stan - , moduleName - , pragmas - , splice - , alternateNumberFormat - , qualifyImportedNames - , codeRange - , gadt - , explicitFixity - , explicitFields - , floskell - , fourmolu - , ormolu - , stylishHaskell - , refactor - , overloadedRecordDot - , semanticTokens - - exposed-modules: - Ide.Arguments - Ide.Main - Ide.Version - HlsPlugins - - other-modules: Paths_haskell_language_server - autogen-modules: Paths_haskell_language_server - hs-source-dirs: src - build-depends: - , async - , base16-bytestring - , bytestring - , containers - , cryptohash-sha1 - , data-default - , ghc - , ghcide == 2.6.0.0 - , githash >=0.1.6.1 - , lsp >= 2.3.0.0 - , hie-bios - , hiedb - , hls-plugin-api == 2.6.0.0 - , optparse-applicative - , optparse-simple - , process - , hls-graph - , safe-exceptions - , sqlite-simple - , unordered-containers - , aeson-pretty - - default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators - -executable haskell-language-server - import: common-deps - -- configuration - , warnings - , pedantic - main-is: Main.hs - hs-source-dirs: exe - - ghc-options: - -threaded - -- allow user RTS overrides - -rtsopts - -- disable idle GC - -- increase nursery size - -- Enable collection of heap statistics - "-with-rtsopts=-I0 -A128M -T" - -Wno-unticked-promoted-constructors - if flag(pedantic) - ghc-options: -Werror - if !os(windows) && flag(dynamic) - -- We want to link against the dyn rts just like official GHC binaries do; - -- the linked rts determines how external libs are loaded dynamically by TH. - -- The standard way of doing this is via the --enable-dynamic-executables Cabal option - -- Unfortunately it doesnt' work, see https://github.com/haskell/haskell-language-server/issues/2659 - -- One can use --ghc-options=-dynamic but this gets applied to the dependencies as well, - -- which results in massive rebuilds and incompatibilities with profiling. - -- So instead we set the -dynamic flag diretly here. - ghc-options: -dynamic - - build-depends: - , aeson - , async - , base16-bytestring - , binary - , bytestring - , containers - , cryptohash-sha1 - , deepseq - , ghc - , ghc-boot-th - , ghcide - , hashable - , haskell-language-server - , lsp - , hie-bios - , hiedb - , lens - , regex-tdfa - , optparse-applicative - , hls-plugin-api - , lens - , mtl - , regex-tdfa - , safe-exceptions - , hls-graph - , sqlite-simple - , stm - , temporary - , transformers - , unordered-containers - - default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators - -executable haskell-language-server-wrapper - import: common-deps - , warnings - , pedantic - main-is: Wrapper.hs - hs-source-dirs: exe - other-modules: Paths_haskell_language_server - autogen-modules: Paths_haskell_language_server - ghc-options: - -threaded - -- allow user RTS overrides - -rtsopts - -- disable idle GC - -- increase nursery size - "-with-rtsopts=-I0 -A128M" - - build-depends: - , data-default - , ghc - , ghc-paths - , ghcide - , gitrev - , haskell-language-server - , hie-bios - , hls-plugin-api - , lsp - , lsp-types - , mtl - , optparse-applicative - , optparse-simple - , process - , transformers - , unliftio-core - if !os(windows) - build-depends: - unix - , containers - - default-language: Haskell2010 - - -test-suite func-test - import: common-deps - , warnings - , pedantic - , refactor - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-tool-depends: - haskell-language-server:haskell-language-server -any, - ghcide:ghcide-test-preprocessor -any - - build-depends: - , bytestring - , data-default - , deepseq - , hashable - , lens - , lens-aeson - , ghcide - , ghcide-test-utils - , hls-test-utils == 2.6.0.0 - , lsp-types - , aeson - , hls-plugin-api - , lsp-test - , containers - , unordered-containers - , row-types - - hs-source-dirs: test/functional test/utils - - main-is: Main.hs - other-modules: - Config - ConfigSchema - Format - FunctionalBadProject - HieBios - Progress - Test.Hls.Command - Test.Hls.Flags - - default-extensions: OverloadedStrings - ghc-options: - -threaded -rtsopts -with-rtsopts=-N - --- Duplicating inclusion plugin conditions until tests are moved to their own packages - if flag(eval) - cpp-options: -Dhls_eval --- formatters - if flag(floskell) - cpp-options: -Dhls_floskell - if flag(fourmolu) - cpp-options: -Dhls_fourmolu - if flag(ormolu) - cpp-options: -Dhls_ormolu - -test-suite wrapper-test - import: common-deps - , warnings - , pedantic - type: exitcode-stdio-1.0 - build-tool-depends: - haskell-language-server:haskell-language-server-wrapper -any, - haskell-language-server:haskell-language-server -any - - default-language: Haskell2010 - build-depends: - process - , hls-test-utils - - hs-source-dirs: test/wrapper - main-is: Main.hs - -benchmark benchmark - -- Depends on shake-bench which is unbuildable after this point - if impl(ghc >= 9.5) - buildable: False - type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -threaded - main-is: Main.hs - hs-source-dirs: bench - build-tool-depends: - ghcide-bench:ghcide-bench, - hp2pretty:hp2pretty, - implicit-hie:gen-hie - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - - build-depends: - aeson, - base == 4.*, - containers, - data-default, - directory, - extra, - filepath, - ghcide-bench, - haskell-language-server, - hls-plugin-api, - lens, - lens-aeson, - optparse-applicative, - shake, - shake-bench == 0.2.*, - text, - yaml +cabal-version: 3.4 +category: Development +name: haskell-language-server +version: 2.7.0.0 +synopsis: LSP server for GHC +description: + Please see the README on GitHub at + +homepage: https://github.com/haskell/haskell-language-server#readme +bug-reports: https://github.com/haskell/haskell-language-server/issues +author: The Haskell IDE Team +maintainer: alan.zimm@gmail.com +copyright: The Haskell IDE Team +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +tested-with: GHC == 9.8.2 || ==9.6.4 || ==9.4.8 || ==9.2.8 +extra-source-files: + README.md + ChangeLog.md + test/testdata/**/*.project + test/testdata/**/*.cabal + test/testdata/**/*.yaml + test/testdata/**/*.hs + test/testdata/**/*.json + + -- These globs should only match test/testdata + plugins/**/*.project + plugins/**/*.expected + plugins/**/*.cabal + plugins/**/*.yaml + plugins/**/*.txt + plugins/**/*.hs + + bindist/wrapper.in + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +common defaults + default-language: GHC2021 + -- Should have been in GHC2021, an oversight + default-extensions: ExplicitNamespaces + +common test-defaults + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +-- Default warnings in HLS +common warnings + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + +flag pedantic + description: Enable -Werror + default: False + manual: True + +-- Allow compiling in pedantic mode +common pedantic + if flag(pedantic) + ghc-options: + -Werror + -- Note [unused-packages] Some packages need CPP conditioned on MIN_VERSION_ghc(x,y,z). + -- MIN_VERSION_ is CPP macro that cabal defines only when is declared as a dependency. + -- But -Wunused-packages still reports it as unused dependency if it's not imported. + -- For packages with such "unused" dependencies we demote -Wunused-packages error + -- (enabled by --flag=pedantic) to warning via -Wwarn=unused-packages. + -Wwarn=unused-packages + +-- Plugin flags are designed for 'cabal install haskell-language-server': +-- - Bulk flags should be default:False +-- - Individual flags should be default:True + +-- The intent of this flag is being able to keep the ghc condition for hackage +-- but skip it via flags in cabal.project as plugins for new ghcs usually +-- are buildable using cabal.project tweaks +flag ignore-plugins-ghc-bounds + description: Force the inclusion of plugins even if they are not buildable by default with a specific ghc version + default: False + manual: True + +flag dynamic + description: Build with the dyn rts + default: True + manual: True + +---------------------------- +---------------------------- +-- PLUGINS +---------------------------- +---------------------------- + +----------------------------- +-- cabal-fmt plugin +----------------------------- + +flag cabalfmt + description: Enable cabal-fmt plugin + default: True + manual: True + +common cabalfmt + if flag(cabalfmt) + build-depends: haskell-language-server:hls-cabal-fmt-plugin + cpp-options: -Dhls_cabalfmt + +flag isolateCabalfmtTests + description: Should tests search for 'cabal-fmt' on the $PATH or shall we install it via build-tool-depends? + -- By default, search on the PATH + default: False + manual: True + +library hls-cabal-fmt-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.CabalFmt + hs-source-dirs: plugins/hls-cabal-fmt-plugin/src + build-depends: + , base >=4.12 && <5 + , directory + , filepath + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp-types + , mtl + , process-extras + , text + +test-suite hls-cabal-fmt-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-cabal-fmt-plugin/test + main-is: Main.hs + build-depends: + , base + , directory + , filepath + , haskell-language-server:hls-cabal-fmt-plugin + , hls-test-utils == 2.7.0.0 + + if flag(isolateCabalfmtTests) + build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6 + +----------------------------- +-- cabal plugin +----------------------------- + +flag cabal + description: Enable cabal plugin + default: True + manual: True + +common cabal + if flag(cabal) + build-depends: haskell-language-server:hls-cabal-plugin + cpp-options: -Dhls_cabal + +library hls-cabal-plugin + import: defaults, pedantic, warnings + exposed-modules: + Ide.Plugin.Cabal + Ide.Plugin.Cabal.Diagnostics + Ide.Plugin.Cabal.Completion.Completer.FilePath + Ide.Plugin.Cabal.Completion.Completer.Module + Ide.Plugin.Cabal.Completion.Completer.Paths + Ide.Plugin.Cabal.Completion.Completer.Simple + Ide.Plugin.Cabal.Completion.Completer.Snippet + Ide.Plugin.Cabal.Completion.Completer.Types + Ide.Plugin.Cabal.Completion.Completions + Ide.Plugin.Cabal.Completion.Data + Ide.Plugin.Cabal.Completion.Types + Ide.Plugin.Cabal.LicenseSuggest + Ide.Plugin.Cabal.Parse + + + build-depends: + , base >=4.12 && <5 + , bytestring + , Cabal-syntax >= 3.7 + , containers + , deepseq + , directory + , filepath + , extra >=1.7.4 + , ghcide == 2.7.0.0 + , hashable + , hls-plugin-api == 2.7.0.0 + , hls-graph == 2.7.0.0 + , lens + , lsp ^>=2.4 + , lsp-types ^>=2.1 + , regex-tdfa ^>=1.3.1 + , stm + , text + , text-rope + , transformers + , unordered-containers >=0.2.10.0 + , containers + hs-source-dirs: plugins/hls-cabal-plugin/src + +test-suite hls-cabal-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-cabal-plugin/test + main-is: Main.hs + other-modules: + Completer + Context + Utils + build-depends: + , base + , bytestring + , Cabal-syntax >= 3.7 + , filepath + , ghcide + , haskell-language-server:hls-cabal-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , text + , text-rope + , transformers + , row-types + +----------------------------- +-- class plugin +----------------------------- + +flag class + description: Enable class plugin + default: True + manual: True + +common class + if flag(class) + build-depends: haskell-language-server:hls-class-plugin + cpp-options: -Dhls_class + +library hls-class-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Class + other-modules: Ide.Plugin.Class.CodeAction + , Ide.Plugin.Class.CodeLens + , Ide.Plugin.Class.ExactPrint + , Ide.Plugin.Class.Types + , Ide.Plugin.Class.Utils + hs-source-dirs: plugins/hls-class-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , deepseq + , extra + , ghc + , ghc-exactprint >= 1.5 + , ghcide == 2.7.0.0 + , hls-graph + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , mtl + , text + , transformers + + default-extensions: + DataKinds + OverloadedStrings + +test-suite hls-class-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-class-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-class-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , row-types + , text + +----------------------------- +-- call-hierarchy plugin +----------------------------- + +flag callHierarchy + description: Enable call hierarchy plugin + default: True + manual: True + +common callHierarchy + if flag(callHierarchy) + build-depends: haskell-language-server:hls-call-hierarchy-plugin + cpp-options: -Dhls_callHierarchy + +library hls-call-hierarchy-plugin + import: defaults, pedantic, warnings + buildable: True + exposed-modules: Ide.Plugin.CallHierarchy + other-modules: + Ide.Plugin.CallHierarchy.Internal + Ide.Plugin.CallHierarchy.Query + Ide.Plugin.CallHierarchy.Types + + hs-source-dirs: plugins/hls-call-hierarchy-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , extra + , ghcide == 2.7.0.0 + , hiedb ^>= 0.6.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp >=2.4 + , sqlite-simple + , text + + default-extensions: DataKinds + +test-suite hls-call-hierarchy-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-call-hierarchy-plugin/test + main-is: Main.hs + build-depends: + , aeson + , base + , containers + , extra + , filepath + , haskell-language-server:hls-call-hierarchy-plugin + , hls-test-utils == 2.7.0.0 + , ghcide:ghcide-test-utils + , lens + , lsp + , lsp-test + , text + +----------------------------- +-- eval plugin +----------------------------- + +flag eval + description: Enable eval plugin + default: True + manual: True + +common eval + if flag(eval) + build-depends: haskell-language-server:hls-eval-plugin + cpp-options: -Dhls_eval + +library hls-eval-plugin + import: defaults, pedantic, warnings + exposed-modules: + Ide.Plugin.Eval + Ide.Plugin.Eval.Types + + hs-source-dirs: plugins/hls-eval-plugin/src + other-modules: + Ide.Plugin.Eval.Code + Ide.Plugin.Eval.CodeLens + Ide.Plugin.Eval.Config + Ide.Plugin.Eval.GHC + Ide.Plugin.Eval.Parse.Comments + Ide.Plugin.Eval.Parse.Option + Ide.Plugin.Eval.Rules + Ide.Plugin.Eval.Util + + build-depends: + , aeson + , base >=4.12 && <5 + , bytestring + , containers + , deepseq + , Diff ^>=0.4.0 + , dlist + , extra + , filepath + , ghc + , ghc-boot-th + , ghcide == 2.7.0.0 + , hls-graph + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , lsp-types + , megaparsec >=9.0 + , mtl + , parser-combinators >=1.2 + , text + , transformers + , unliftio + , unordered-containers + + default-extensions: + DataKinds + +test-suite hls-eval-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-eval-plugin/test + main-is: Main.hs + ghc-options: -fno-ignore-asserts + build-depends: + , aeson + , base + , containers + , extra + , filepath + , haskell-language-server:hls-eval-plugin + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , text + , row-types + +----------------------------- +-- import lens plugin +----------------------------- + +common importLens + if flag(importLens) + build-depends: haskell-language-server:hls-explicit-imports-plugin + cpp-options: -Dhls_importLens + +flag importLens + description: Enable importLens plugin + default: True + manual: True + +library hls-explicit-imports-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.ExplicitImports + hs-source-dirs: plugins/hls-explicit-imports-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , deepseq + , ghc + , ghcide == 2.7.0.0 + , hls-graph + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , mtl + , text + , transformers + + default-extensions: + DataKinds + +test-suite hls-explicit-imports-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-explicit-imports-plugin/test + main-is: Main.hs + build-depends: + , base + , extra + , filepath + , haskell-language-server:hls-explicit-imports-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , row-types + , text + +----------------------------- +-- rename plugin +----------------------------- + +flag rename + description: Enable rename plugin + default: True + manual: True + +common rename + if flag(rename) + build-depends: haskell-language-server:hls-rename-plugin + cpp-options: -Dhls_rename + +library hls-rename-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Rename + hs-source-dirs: plugins/hls-rename-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , ghcide == 2.7.0.0 + , hashable + , hiedb ^>= 0.6.0.0 + , hie-compat + , hls-plugin-api == 2.7.0.0 + , haskell-language-server:hls-refactor-plugin + , lens + , lsp + , lsp-types + , mtl + , mod + , syb + , text + , transformers + , unordered-containers + + +test-suite hls-rename-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-rename-plugin/test + main-is: Main.hs + build-depends: + , aeson + , base + , containers + , filepath + , hls-plugin-api + , haskell-language-server:hls-rename-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- retrie plugin +----------------------------- + +flag retrie + description: Enable retrie plugin + default: True + manual: True + +common retrie + if flag(retrie) + build-depends: haskell-language-server:hls-retrie-plugin + cpp-options: -Dhls_retrie + +library hls-retrie-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Retrie + hs-source-dirs: plugins/hls-retrie-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , bytestring + , containers + , directory + , extra + , ghc + , ghcide == 2.7.0.0 + , hashable + , hls-plugin-api == 2.7.0.0 + , haskell-language-server:hls-refactor-plugin + , lens + , lsp + , lsp-types + , mtl + , retrie >=0.1.1.0 + , safe-exceptions + , stm + , text + , transformers + , unordered-containers + + default-extensions: + DataKinds + +test-suite hls-retrie-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-retrie-plugin/test + main-is: Main.hs + build-depends: + , base + , containers + , filepath + , hls-plugin-api + , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin} + , hls-test-utils == 2.7.0.0 + , text + +----------------------------- +-- hlint plugin +----------------------------- + +flag hlint + description: Enable hlint plugin + default: True + manual: True + +common hlint + if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: haskell-language-server:hls-hlint-plugin + cpp-options: -Dhls_hlint + +library hls-hlint-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Hlint + hs-source-dirs: plugins/hls-hlint-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , bytestring + , containers + , deepseq + , filepath + , ghcide == 2.7.0.0 + , hashable + , hlint >= 3.5 && < 3.9 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , mtl + , refact + , regex-tdfa + , stm + , temporary + , text + , transformers + , unordered-containers + , ghc-lib-parser + , ghc-lib-parser-ex + , apply-refact + + cpp-options: -DHLINT_ON_GHC_LIB + + default-extensions: + DataKinds + +test-suite hls-hlint-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-hlint-plugin/test + main-is: Main.hs + build-depends: + aeson + , base + , containers + , filepath + , haskell-language-server:hls-hlint-plugin + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , row-types + , text + +----------------------------- +-- stan plugin +----------------------------- + +flag stan + description: Enable stan plugin + default: True + manual: True + +common stan + if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) + build-depends: haskell-language-server:hls-stan-plugin + cpp-options: -Dhls_stan + +library hls-stan-plugin + import: defaults, pedantic, warnings + if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) + buildable: True + else + buildable: False + exposed-modules: Ide.Plugin.Stan + hs-source-dirs: plugins/hls-stan-plugin/src + build-depends: + base + , deepseq + , hashable + , hie-compat + , hls-plugin-api + , ghcide + , lsp-types + , text + , unordered-containers + , stan >= 0.1.2.0 + , trial + , directory + + default-extensions: + LambdaCase + TypeFamilies + DuplicateRecordFields + OverloadedStrings + +test-suite hls-stan-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) + buildable: True + else + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-stan-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-stan-plugin + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , text + default-extensions: + OverloadedStrings + +----------------------------- +-- module name plugin +----------------------------- + +flag moduleName + description: Enable moduleName plugin + default: True + manual: True + +common moduleName + if flag(moduleName) + build-depends: haskell-language-server:hls-module-name-plugin + cpp-options: -Dhls_moduleName + +library hls-module-name-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.ModuleName + hs-source-dirs: plugins/hls-module-name-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , directory + , filepath + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp + , text + , transformers + + +test-suite hls-module-name-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-module-name-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-module-name-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- pragmas plugin +----------------------------- + +flag pragmas + description: Enable pragmas plugin + default: True + manual: True + +common pragmas + if flag(pragmas) + build-depends: haskell-language-server:hls-pragmas-plugin + cpp-options: -Dhls_pragmas + +library hls-pragmas-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Pragmas + hs-source-dirs: plugins/hls-pragmas-plugin/src + build-depends: + , base >=4.12 && <5 + , extra + , fuzzy + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , text + , transformers + , containers + +test-suite hls-pragmas-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-pragmas-plugin/test + main-is: Main.hs + build-depends: + , aeson + , base + , filepath + , haskell-language-server:hls-pragmas-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , text + +----------------------------- +-- splice plugin +----------------------------- + +flag splice + description: Enable splice plugin + default: True + manual: True + +common splice + if flag(splice) + build-depends: haskell-language-server:hls-splice-plugin + cpp-options: -Dhls_splice + +library hls-splice-plugin + import: defaults, pedantic, warnings + exposed-modules: + Ide.Plugin.Splice + Ide.Plugin.Splice.Types + + hs-source-dirs: plugins/hls-splice-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , extra + , foldl + , ghc + , ghc-exactprint + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , haskell-language-server:hls-refactor-plugin + , lens + , lsp + , mtl + , syb + , text + , transformers + , unliftio-core + + default-extensions: + DataKinds + +test-suite hls-splice-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-splice-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-splice-plugin + , hls-test-utils == 2.7.0.0 + , text + , row-types + +----------------------------- +-- alternate number format plugin +----------------------------- + +flag alternateNumberFormat + description: Enable Alternate Number Format plugin + default: True + manual: True + +common alternateNumberFormat + if flag(alternateNumberFormat) + build-depends: haskell-language-server:hls-alternate-number-format-plugin + cpp-options: -Dhls_alternateNumberFormat + +library hls-alternate-number-format-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion + other-modules: Ide.Plugin.Literals + hs-source-dirs: plugins/hls-alternate-number-format-plugin/src + build-depends: + , base >=4.12 && < 5 + , containers + , extra + , ghcide == 2.7.0.0 + , ghc-boot-th + , hls-graph + , hls-plugin-api == 2.7.0.0 + , lens + , lsp ^>=2.4 + , mtl + , regex-tdfa + , syb + , text + + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + +test-suite hls-alternate-number-format-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-alternate-number-format-plugin/test + other-modules: Properties.Conversion + main-is: Main.hs + ghc-options: -fno-ignore-asserts + build-depends: + , base >=4.12 && < 5 + , filepath + , haskell-language-server:hls-alternate-number-format-plugin + , hls-test-utils == 2.7.0.0 + , regex-tdfa + , tasty-quickcheck + , text + + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + +----------------------------- +-- qualify imported names plugin +----------------------------- + +flag qualifyImportedNames + description: Enable qualifyImportedNames plugin + default: True + manual: True + +common qualifyImportedNames + if flag(qualifyImportedNames) + build-depends: haskell-language-server:hls-qualify-imported-names-plugin + cpp-options: -Dhls_qualifyImportedNames + +library hls-qualify-imported-names-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.QualifyImportedNames + hs-source-dirs: plugins/hls-qualify-imported-names-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , text + , dlist + , transformers + + default-extensions: + DataKinds + +test-suite hls-qualify-imported-names-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-qualify-imported-names-plugin/test + main-is: Main.hs + build-depends: + , base + , text + , filepath + , haskell-language-server:hls-qualify-imported-names-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- code range plugin +----------------------------- + +flag codeRange + description: Enable Code Range plugin + default: True + manual: True + +common codeRange + if flag(codeRange) + build-depends: haskell-language-server:hls-code-range-plugin + cpp-options: -Dhls_codeRange + +library hls-code-range-plugin + import: defaults, pedantic, warnings + exposed-modules: + Ide.Plugin.CodeRange + Ide.Plugin.CodeRange.Rules + other-modules: + Ide.Plugin.CodeRange.ASTPreProcess + hs-source-dirs: plugins/hls-code-range-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , deepseq + , extra + , ghcide == 2.7.0.0 + , hashable + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , mtl + , semigroupoids + , transformers + , vector + +test-suite hls-code-range-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-code-range-plugin/test + main-is: Main.hs + other-modules: + Ide.Plugin.CodeRangeTest + Ide.Plugin.CodeRange.RulesTest + build-depends: + , base + , bytestring + , filepath + , haskell-language-server:hls-code-range-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp + , lsp-test + , transformers + , vector + +----------------------------- +-- change type signature plugin +----------------------------- + +flag changeTypeSignature + description: Enable changeTypeSignature plugin + default: True + manual: True + +common changeTypeSignature + if flag(changeTypeSignature) + build-depends: haskell-language-server:hls-change-type-signature-plugin + cpp-options: -Dhls_changeTypeSignature + +library hls-change-type-signature-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.ChangeTypeSignature + hs-source-dirs: plugins/hls-change-type-signature-plugin/src + build-depends: + , base >=4.12 && < 5 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp-types + , regex-tdfa + , syb + , text + , transformers + , containers + default-extensions: + DataKinds + ExplicitNamespaces + OverloadedStrings + RecordWildCards + + +test-suite hls-change-type-signature-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-change-type-signature-plugin/test + main-is: Main.hs + build-depends: + , base >=4.12 && < 5 + , filepath + , haskell-language-server:hls-change-type-signature-plugin + , hls-test-utils == 2.7.0.0 + , regex-tdfa + , text + default-extensions: + OverloadedStrings + ViewPatterns + +----------------------------- +-- gadt plugin +----------------------------- + +flag gadt + description: Enable gadt plugin + default: True + manual: True + +common gadt + if flag(gadt) + build-depends: haskell-language-server:hls-gadt-plugin + cpp-options: -Dhls_gadt + +library hls-gadt-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.GADT + other-modules: Ide.Plugin.GHC + hs-source-dirs: plugins/hls-gadt-plugin/src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , extra + , ghc + , ghcide == 2.7.0.0 + , ghc-exactprint + , hls-plugin-api == 2.7.0.0 + , haskell-language-server:hls-refactor-plugin + , lens + , lsp >=2.4 + , mtl + , text + , transformers + + default-extensions: DataKinds + +test-suite hls-gadt-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-gadt-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-gadt-plugin + , hls-test-utils == 2.7.0.0 + , text + +----------------------------- +-- explicit fixity plugin +----------------------------- + +flag explicitFixity + description: Enable explicitFixity plugin + default: True + manual: True + +common explicitFixity + if flag(explicitFixity) + build-depends: haskell-language-server:hls-explicit-fixity-plugin + cpp-options: -DexplicitFixity + +library hls-explicit-fixity-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.ExplicitFixity + hs-source-dirs: plugins/hls-explicit-fixity-plugin/src + build-depends: + base >=4.12 && <5 + , containers + , deepseq + , extra + , ghcide == 2.7.0.0 + , hashable + , hls-plugin-api == 2.7.0.0 + , lsp >=2.4 + , text + + default-extensions: DataKinds + +test-suite hls-explicit-fixity-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-explicit-fixity-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-explicit-fixity-plugin + , hls-test-utils == 2.7.0.0 + , text + +----------------------------- +-- explicit fields plugin +----------------------------- + +flag explicitFields + description: Enable explicitFields plugin + default: True + manual: True + +common explicitFields + if flag(explicitFields) + build-depends: haskell-language-server:hls-explicit-record-fields-plugin + cpp-options: -DexplicitFields + +library hls-explicit-record-fields-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.ExplicitFields + build-depends: + , base >=4.12 && <5 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp + , lens + , hls-graph + , text + , syb + , transformers + , containers + , aeson + hs-source-dirs: plugins/hls-explicit-record-fields-plugin/src + + if flag(pedantic) + ghc-options: -Wwarn=incomplete-record-updates + +test-suite hls-explicit-record-fields-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-explicit-record-fields-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , text + , haskell-language-server:hls-explicit-record-fields-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- overloaded record dot plugin +----------------------------- + +flag overloadedRecordDot + description: Enable overloadedRecordDot plugin + default: True + manual: True + +common overloadedRecordDot + if flag(overloadedRecordDot) + build-depends: haskell-language-server:hls-overloaded-record-dot-plugin + cpp-options: -Dhls_overloaded_record_dot + +library hls-overloaded-record-dot-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.OverloadedRecordDot + build-depends: + , base >=4.16 && <5 + , aeson + , ghcide + , hls-plugin-api + , lsp + , lens + , hls-graph + , text + , syb + , transformers + , containers + , deepseq + hs-source-dirs: plugins/hls-overloaded-record-dot-plugin/src + +test-suite hls-overloaded-record-dot-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-overloaded-record-dot-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , text + , haskell-language-server:hls-overloaded-record-dot-plugin + , hls-test-utils == 2.7.0.0 + + +----------------------------- +-- floskell plugin +----------------------------- + +flag floskell + description: Enable floskell plugin + default: True + manual: True + +common floskell + if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds)) + build-depends: haskell-language-server:hls-floskell-plugin + cpp-options: -Dhls_floskell + +library hls-floskell-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Floskell + hs-source-dirs: plugins/hls-floskell-plugin/src + build-depends: + , base >=4.12 && <5 + , floskell ^>=0.11.0 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp-types ^>=2.1 + , mtl + , text + + +test-suite hls-floskell-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-floskell-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-floskell-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- fourmolu plugin +----------------------------- + +flag fourmolu + description: Enable fourmolu plugin + default: True + manual: True + +common fourmolu + if flag(fourmolu) + build-depends: haskell-language-server:hls-fourmolu-plugin + cpp-options: -Dhls_fourmolu + +library hls-fourmolu-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Fourmolu + hs-source-dirs: plugins/hls-fourmolu-plugin/src + build-depends: + , base >=4.12 && <5 + , filepath + , fourmolu ^>= 0.14 || ^>= 0.15 + , ghc-boot-th + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp + , mtl + , process-extras >= 0.7.1 + , text + , transformers + + +test-suite hls-fourmolu-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-fourmolu-plugin/test + main-is: Main.hs + build-tool-depends: + fourmolu:fourmolu + build-depends: + , base >=4.12 && <5 + , aeson + , filepath + , haskell-language-server:hls-fourmolu-plugin + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lsp-test + +----------------------------- +-- ormolu plugin +----------------------------- + +flag ormolu + description: Enable ormolu plugin + default: True + manual: True + +common ormolu + if flag(ormolu) + build-depends: haskell-language-server:hls-ormolu-plugin + cpp-options: -Dhls_ormolu + +library hls-ormolu-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.Ormolu + hs-source-dirs: plugins/hls-ormolu-plugin/src + build-depends: + , base >=4.12 && <5 + , extra + , filepath + , ghc-boot-th + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp + , mtl + , process-extras >= 0.7.1 + , ormolu ^>=0.1.2 || ^>= 0.2 || ^>= 0.3 || ^>= 0.5 || ^>= 0.6 || ^>= 0.7 + , text + , transformers + + +test-suite hls-ormolu-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-ormolu-plugin/test + main-is: Main.hs + build-tool-depends: + ormolu:ormolu + build-depends: + , base + , aeson + , filepath + , haskell-language-server:hls-ormolu-plugin + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lsp-types + , ormolu + +----------------------------- +-- stylish-haskell plugin +----------------------------- + +flag stylishHaskell + description: Enable stylishHaskell plugin + default: True + manual: True + +common stylishHaskell + if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: haskell-language-server:hls-stylish-haskell-plugin + cpp-options: -Dhls_stylishHaskell + +library hls-stylish-haskell-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.StylishHaskell + hs-source-dirs: plugins/hls-stylish-haskell-plugin/src + build-depends: + , base >=4.12 && <5 + , directory + , filepath + , ghc-boot-th + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp-types + , mtl + , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14.2 + , text + + +test-suite hls-stylish-haskell-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-stylish-haskell-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-stylish-haskell-plugin + , hls-test-utils == 2.7.0.0 + +----------------------------- +-- refactor plugin +----------------------------- + +flag refactor + description: Enable refactor plugin + default: True + manual: True + +common refactor + if flag(refactor) + build-depends: haskell-language-server:hls-refactor-plugin + cpp-options: -Dhls_refactor + +library hls-refactor-plugin + import: defaults, pedantic, warnings + exposed-modules: Development.IDE.GHC.ExactPrint + Development.IDE.GHC.Compat.ExactPrint + Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.Util + Development.IDE.GHC.Dump + other-modules: Development.IDE.Plugin.CodeAction.Args + Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.CodeAction.PositionIndexed + Development.IDE.Plugin.Plugins.AddArgument + Development.IDE.Plugin.Plugins.Diagnostic + Development.IDE.Plugin.Plugins.FillHole + Development.IDE.Plugin.Plugins.FillTypeWildcard + Development.IDE.Plugin.Plugins.ImportUtils + default-extensions: + CPP + DataKinds + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExplicitNamespaces + FunctionalDependencies + LambdaCase + OverloadedStrings + PatternSynonyms + RecordWildCards + ViewPatterns + hs-source-dirs: plugins/hls-refactor-plugin/src + build-depends: + , base >=4.12 && <5 + , ghc + , bytestring + , ghc-boot + , regex-tdfa + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lsp + , text + , transformers + , unordered-containers + , containers + , ghc-exactprint < 1 || >= 1.4 + , extra + , retrie + , syb + , hls-graph + , dlist + , deepseq + , mtl + , lens + , data-default + , time + -- FIXME: Only needed to workaround for qualified imports in GHC 9.4 + , regex-applicative + , parser-combinators + +test-suite hls-refactor-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-refactor-plugin/test + main-is: Main.hs + other-modules: Test.AddArgument + ghc-options: -O0 + build-depends: + , base + , filepath + , haskell-language-server:hls-refactor-plugin + , hls-test-utils == 2.7.0.0 + , lens + , lsp-types + , text + , hls-plugin-api + , parser-combinators + , data-default + , extra + , ghcide:{ghcide, ghcide-test-utils} + , shake + , hls-plugin-api + , lsp-test + , directory + , regex-tdfa + , tasty-hunit + , tasty-expected-failure + , tasty + +----------------------------- +-- semantic tokens plugin +----------------------------- + +flag semanticTokens + description: Enable semantic tokens plugin + default: True + manual: True + +common semanticTokens + if flag(semanticTokens) + build-depends: haskell-language-server:hls-semantic-tokens-plugin + cpp-options: -Dhls_semanticTokens + +library hls-semantic-tokens-plugin + import: defaults, pedantic, warnings + buildable: True + exposed-modules: + Ide.Plugin.SemanticTokens + Ide.Plugin.SemanticTokens.Types + Ide.Plugin.SemanticTokens.Mappings + other-modules: + Ide.Plugin.SemanticTokens.Query + Ide.Plugin.SemanticTokens.SemanticConfig + Ide.Plugin.SemanticTokens.Utils + Ide.Plugin.SemanticTokens.Tokenize + Ide.Plugin.SemanticTokens.Internal + + hs-source-dirs: plugins/hls-semantic-tokens-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , extra + , text-rope + , mtl >= 2.2 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp >=2.4 + , text + , transformers + , bytestring + , syb + , array + , deepseq + , dlist + , hls-graph == 2.7.0.0 + , template-haskell + , data-default + , stm + , stm-containers + + default-extensions: DataKinds + +test-suite hls-semantic-tokens-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-semantic-tokens-plugin/test + main-is: SemanticTokensTest.hs + + build-depends: + , aeson + , base + , containers + , filepath + , haskell-language-server:hls-semantic-tokens-plugin + , hls-test-utils == 2.7.0.0 + , ghcide:ghcide-test-utils + , hls-plugin-api + , lens + , lsp + , text-rope + , lsp-test + , text + , data-default + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , data-default + , row-types + +---------------------------- +---------------------------- +-- HLS +---------------------------- +---------------------------- + +library + import: defaults + , warnings + , pedantic + -- plugins + , cabal + , callHierarchy + , cabalfmt + , changeTypeSignature + , class + , eval + , importLens + , rename + , retrie + , hlint + , stan + , moduleName + , pragmas + , splice + , alternateNumberFormat + , qualifyImportedNames + , codeRange + , gadt + , explicitFixity + , explicitFields + , floskell + , fourmolu + , ormolu + , stylishHaskell + , refactor + , overloadedRecordDot + , semanticTokens + + exposed-modules: + Ide.Arguments + Ide.Main + Ide.Version + HlsPlugins + + other-modules: Paths_haskell_language_server + autogen-modules: Paths_haskell_language_server + hs-source-dirs: src + build-depends: + , aeson-pretty + , base >=4.16 && <5 + , data-default + , directory + , extra + , filepath + , ghc + , ghcide == 2.7.0.0 + , githash >=0.1.6.1 + , hie-bios + , hls-plugin-api == 2.7.0.0 + , optparse-applicative + , optparse-simple + , prettyprinter >= 1.7 + , process + , text + + default-extensions: DataKinds + +executable haskell-language-server + import: defaults + , warnings + , pedantic + main-is: Main.hs + hs-source-dirs: exe + + ghc-options: + -threaded + -- allow user RTS overrides + -rtsopts + -- disable idle GC + -- increase nursery size + -- Enable collection of heap statistics + "-with-rtsopts=-I0 -A128M -T" + if flag(pedantic) + ghc-options: -Werror + if !os(windows) && flag(dynamic) + -- We want to link against the dyn rts just like official GHC binaries do; + -- the linked rts determines how external libs are loaded dynamically by TH. + -- The standard way of doing this is via the --enable-dynamic-executables Cabal option + -- Unfortunately it doesnt' work, see https://github.com/haskell/haskell-language-server/issues/2659 + -- One can use --ghc-options=-dynamic but this gets applied to the dependencies as well, + -- which results in massive rebuilds and incompatibilities with profiling. + -- So instead we set the -dynamic flag diretly here. + ghc-options: -dynamic + + build-depends: + , base >=4.16 && <5 + , haskell-language-server + , hls-plugin-api + , lsp + , prettyprinter >= 1.7 + , text + + default-extensions: DataKinds + +executable haskell-language-server-wrapper + import: defaults + , warnings + , pedantic + main-is: Wrapper.hs + hs-source-dirs: exe + other-modules: Paths_haskell_language_server + autogen-modules: Paths_haskell_language_server + ghc-options: + -threaded + -- allow user RTS overrides + -rtsopts + -- disable idle GC + -- increase nursery size + "-with-rtsopts=-I0 -A128M" + + build-depends: + , base >=4.16 && <5 + , data-default + , directory + , extra + , filepath + , ghcide + , haskell-language-server + , hie-bios + , hls-plugin-api + , lsp + , lsp-types + , text + , transformers + , unliftio-core + if !os(windows) + build-depends: + , unix + , containers + else + build-depends: + , process + +test-suite func-test + import: defaults + , test-defaults + , warnings + , pedantic + , refactor + type: exitcode-stdio-1.0 + build-tool-depends: + haskell-language-server:haskell-language-server, + ghcide:ghcide-test-preprocessor + + build-depends: + , aeson + , base >=4.16 && <5 + , bytestring + , containers + , deepseq + , extra + , filepath + , ghcide:{ghcide, ghcide-test-utils} + , hashable + , hls-plugin-api + , hls-test-utils == 2.7.0.0 + , lens + , lsp-test + , lsp-types + , text + , unordered-containers + + hs-source-dirs: test/functional test/utils + + main-is: Main.hs + other-modules: + Config + ConfigSchema + Format + FunctionalBadProject + HieBios + Progress + Test.Hls.Command + Test.Hls.Flags + + default-extensions: OverloadedStrings + +-- Duplicating inclusion plugin conditions until tests are moved to their own packages + if flag(eval) + cpp-options: -Dhls_eval +-- formatters + if flag(floskell) + cpp-options: -Dhls_floskell + if flag(fourmolu) + cpp-options: -Dhls_fourmolu + if flag(ormolu) + cpp-options: -Dhls_ormolu + +test-suite wrapper-test + import: defaults + , warnings + , pedantic + type: exitcode-stdio-1.0 + build-tool-depends: + haskell-language-server:haskell-language-server-wrapper, + haskell-language-server:haskell-language-server + + build-depends: + , base >=4.16 && <5 + , extra + , hls-test-utils == 2.7.0.0 + , process + + hs-source-dirs: test/wrapper + main-is: Main.hs + +benchmark benchmark + import: defaults, warnings + -- Depends on shake-bench which is unbuildable after this point + if impl(ghc >= 9.5) + buildable: False + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: Main.hs + hs-source-dirs: bench + build-tool-depends: + ghcide-bench:ghcide-bench, + hp2pretty:hp2pretty, + implicit-hie:gen-hie + default-extensions: + LambdaCase + RecordWildCards + ViewPatterns + + build-depends: + , aeson + , base >=4.16 && <5 + , containers + , data-default + , directory + , extra + , filepath + , ghcide-bench + , haskell-language-server + , hls-plugin-api + , lens + , lens-aeson + , shake + , shake-bench == 0.2.* + , text + , yaml diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where + +import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (MonadIO) +import qualified Data.Map as Map +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + IdeState, RuleResult, Rules, + define, realSrcSpanToRange, + use) +import Development.IDE.Core.PluginUtils +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (getSrcSpan) +import Development.IDE.GHC.Util (getExtensions) +import Development.IDE.Graph.Classes (Hashable, NFData, rnf) +import Development.IDE.Spans.Pragmas (NextPragmaInfo, + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger as Logger +import Ide.Plugin.Conversion (AlternateFormat, + ExtensionNeeded (NeedsExtension, NoExtension), + alternateFormat) +import Ide.Plugin.Error +import Ide.Plugin.Literals +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types + +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake msg -> pretty msg + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder pId = (defaultPluginDescriptor pId "Provides code actions to convert numeric literals to different formats") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler + , pluginRules = collectLiteralsRule recorder + } + +data CollectLiterals = CollectLiterals + deriving (Show, Eq, Generic) + +instance Hashable CollectLiterals +instance NFData CollectLiterals + +type instance RuleResult CollectLiterals = CollectLiteralsResult + +data CollectLiteralsResult = CLR + { literals :: RangeMap Literal + , enabledExtensions :: [GhcExtension] + } deriving (Generic) + +newtype GhcExtension = GhcExtension { unExt :: Extension } + +instance NFData GhcExtension where + rnf x = x `seq` () + +instance Show CollectLiteralsResult where + show _ = "" + +instance NFData CollectLiteralsResult + +collectLiteralsRule :: Recorder (WithPriority Log) -> Rules () +collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do + pm <- use GetParsedModule nfp + -- get the current extensions active and transform them into FormatTypes + let exts = map GhcExtension . getExtensions <$> pm + -- collect all the literals for a file + lits = collectLiterals . pm_parsed_source <$> pm + litMap = RangeMap.fromList (realSrcSpanToRange . getSrcSpan) <$> lits + pure ([], CLR <$> litMap <*> exts) + +codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do + nfp <- getNormalizedFilePathE (docId ^. L.uri) + CLR{..} <- requestLiterals pId state nfp + pragma <- getFirstPragma pId state nfp + -- remove any invalid literals (see validTarget comment) + let litsInRange = RangeMap.filterByRange currRange literals + -- generate alternateFormats and zip with the literal that generated the alternates + literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange + -- make a code action for every literal and its' alternates (then flatten the result) + actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs + pure $ InL actions + where + mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction + mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction { + _title = mkCodeActionTitle lit af enabled + , _kind = Just $ CodeActionKind_Custom "quickfix.literals.style" + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkWorkspaceEdit nfp edits + , _command = Nothing + , _data_ = Nothing + } + where + edits = [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit + pragmaEdit = case ext of + NeedsExtension ext' -> [insertNewPragma npi ext' | needsExtension ext' enabled] + NoExtension -> [] + + mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit + mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing + where + changes = Just $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, edits)] + +mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text +mkCodeActionTitle lit (alt, ext) ghcExts + | (NeedsExtension ext') <- ext + , needsExtension ext' ghcExts = title <> " (needs extension: " <> T.pack (show ext') <> ")" + | otherwise = title + where + title = "Convert " <> getSrcText lit <> " into " <> alt + + +-- | Checks whether the extension given is already enabled +needsExtension :: Extension -> [GhcExtension] -> Bool +needsExtension ext ghcExts = ext `notElem` map unExt ghcExts + +requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult +requestLiterals (PluginId pId) state = + runActionE (unpack pId <> ".CollectLiterals") state + . useE CollectLiterals diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.Conversion ( + alternateFormat + , hexRegex + , hexFloatRegex + , binaryRegex + , octalRegex + , decimalRegex + , numDecimalRegex + , matchLineRegex + , toOctal + , toDecimal + , toBinary + , toHex + , toFloatDecimal + , toFloatExpDecimal + , toHexFloat + , AlternateFormat + , ExtensionNeeded(..) +) where + +import Data.List (delete) +import Data.List.Extra (enumerate, upper) +import Data.Maybe (mapMaybe) +import Data.Ratio (denominator, numerator) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.Graph.Classes (NFData) +import GHC.Generics (Generic) +import GHC.LanguageExtensions.Type (Extension (..)) +import GHC.Show (intToDigit) +import Ide.Plugin.Literals (Literal (..), getSrcText) +import Numeric +import Text.Regex.TDFA ((=~)) + +data FormatType = IntFormat IntFormatType + | FracFormat FracFormatType + | NoFormat + deriving (Show, Eq, Generic) + +instance NFData FormatType + +data IntFormatType = IntDecimalFormat + | HexFormat + | OctalFormat + | BinaryFormat + | NumDecimalFormat + deriving (Show, Eq, Generic, Bounded, Enum) + +instance NFData IntFormatType + +data FracFormatType = FracDecimalFormat + | HexFloatFormat + | ExponentFormat + deriving (Show, Eq, Generic, Bounded, Enum) + +instance NFData FracFormatType + +data ExtensionNeeded = NoExtension + | NeedsExtension Extension + +type AlternateFormat = (Text, ExtensionNeeded) + +-- | Generate alternate formats for a single Literal based on FormatType's given. +alternateFormat :: Literal -> [AlternateFormat] +alternateFormat lit = case lit of + IntLiteral _ _ val -> map (alternateIntFormat val) (removeCurrentFormatInt lit) + FracLiteral _ _ val -> if denominator val == 1 -- floats that can be integers we can represent as ints + then map (alternateIntFormat (numerator val)) (removeCurrentFormatInt lit) + else map (alternateFracFormat val) (removeCurrentFormatFrac lit) + +alternateIntFormat :: Integer -> IntFormatType -> AlternateFormat +alternateIntFormat val = \case + IntDecimalFormat -> (T.pack $ toDecimal val, NoExtension) + HexFormat -> (T.pack $ toHex val, NoExtension) + OctalFormat -> (T.pack $ toOctal val, NoExtension) + BinaryFormat -> (T.pack $ toBinary val, NeedsExtension BinaryLiterals) + NumDecimalFormat -> (T.pack $ toFloatExpDecimal (fromInteger @Double val), NeedsExtension NumDecimals) + +alternateFracFormat :: Rational -> FracFormatType -> AlternateFormat +alternateFracFormat val = \case + FracDecimalFormat -> (T.pack $ toFloatDecimal (fromRational @Double val), NoExtension) + ExponentFormat -> (T.pack $ toFloatExpDecimal (fromRational @Double val), NoExtension) + HexFloatFormat -> (T.pack $ toHexFloat (fromRational @Double val), NeedsExtension HexFloatLiterals) + +-- given a Literal compute it's current Format and delete it from the list of available formats +removeCurrentFormat :: (Foldable t, Eq a) => [a] -> t a -> [a] +removeCurrentFormat fmts toRemove = foldl (flip delete) fmts toRemove + +removeCurrentFormatInt :: Literal -> [IntFormatType] +removeCurrentFormatInt (getSrcText -> srcText) = removeCurrentFormat intFormats (filterIntFormats $ sourceToFormatType srcText) + +removeCurrentFormatFrac :: Literal -> [FracFormatType] +removeCurrentFormatFrac (getSrcText -> srcText) = removeCurrentFormat fracFormats (filterFracFormats $ sourceToFormatType srcText) + +filterIntFormats :: [FormatType] -> [IntFormatType] +filterIntFormats = mapMaybe getIntFormat + where + getIntFormat (IntFormat f) = Just f + getIntFormat _ = Nothing + +filterFracFormats :: [FormatType] -> [FracFormatType] +filterFracFormats = mapMaybe getFracFormat + where + getFracFormat (FracFormat f) = Just f + getFracFormat _ = Nothing + +intFormats :: [IntFormatType] +intFormats = enumerate + +fracFormats :: [FracFormatType] +fracFormats = enumerate + +-- | Regex to match a Haskell Hex Literal +hexRegex :: Text +hexRegex = "0[xX][a-fA-F0-9]+" + +-- | Regex to match a Haskell Hex Float Literal +hexFloatRegex :: Text +hexFloatRegex = "0[xX][a-fA-F0-9]+(\\.)?[a-fA-F0-9]*(p[+-]?[0-9]+)?" + +-- | Regex to match a Haskell Binary Literal +binaryRegex :: Text +binaryRegex = "0[bB][0|1]+" + +-- | Regex to match a Haskell Octal Literal +octalRegex :: Text +octalRegex = "0[oO][0-8]+" + +-- | Regex to match a Haskell Decimal Literal (no decimal points) +decimalRegex :: Text +decimalRegex = "[0-9]+(\\.[0-9]+)?" + +-- | Regex to match a Haskell Literal with an explicit exponent +numDecimalRegex :: Text +numDecimalRegex = "[0-9]+\\.[0-9]+[eE][+-]?[0-9]+" + +-- we want to be explicit in our matches +-- so we need to match the beginning/end of the source text +-- | Wraps a Regex with a beginning ("^") and end ("$") token +matchLineRegex :: Text -> Text +matchLineRegex regex = "^" <> regex <> "$" + +sourceToFormatType :: Text -> [FormatType] +sourceToFormatType srcText + | srcText =~ matchLineRegex hexRegex = [IntFormat HexFormat] + | srcText =~ matchLineRegex hexFloatRegex = [FracFormat HexFloatFormat] + | srcText =~ matchLineRegex octalRegex = [IntFormat OctalFormat] + | srcText =~ matchLineRegex binaryRegex = [IntFormat BinaryFormat] + -- can either be a NumDecimal or just a regular Fractional with an exponent + -- otherwise we wouldn't need to return a list + | srcText =~ matchLineRegex numDecimalRegex = [IntFormat NumDecimalFormat, FracFormat ExponentFormat] + -- just assume we are in base 10 with no decimals + | otherwise = [IntFormat IntDecimalFormat, FracFormat FracDecimalFormat] + +toBase :: (Num a, Ord a) => (a -> ShowS) -> String -> a -> String +toBase conv header n + | n < 0 = '-' : header <> upper (conv (abs n) "") + | otherwise = header <> upper (conv n "") + +#if MIN_VERSION_base(4,17,0) +toOctal, toDecimal, toBinary, toHex :: Integral a => a -> String +#else +toOctal, toDecimal, toBinary, toHex:: (Integral a, Show a) => a -> String +#endif + +toBinary = toBase showBin_ "0b" + where + -- this is not defined in base < 4.16 + showBin_ = showIntAtBase 2 intToDigit + +toOctal = toBase showOct "0o" + +toDecimal = toBase showInt "" + +toHex = toBase showHex "0x" + +toFloatDecimal :: RealFloat a => a -> String +toFloatDecimal val = showFFloat Nothing val "" + +toFloatExpDecimal :: RealFloat a => a -> String +toFloatExpDecimal val = showEFloat Nothing val "" + +toHexFloat :: RealFloat a => a -> String +toHexFloat val = showHFloat val "" diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.Literals ( + collectLiterals + , Literal(..) + , getSrcText + , getSrcSpan +) where + +import Data.Maybe (maybeToList) +import Data.Text (Text) +import qualified Data.Text as T +#if __GLASGOW_HASKELL__ >= 908 +import qualified Data.Text.Encoding as T +#endif +import Development.IDE.GHC.Compat hiding (getSrcSpan) +import Development.IDE.Graph.Classes (NFData (rnf)) +import Generics.SYB (Data, everything, extQ) +import qualified GHC.Generics as GHC + +-- data type to capture what type of literal we are dealing with +-- provides location and possibly source text (for OverLits) as well as it's value +-- we currently don't have any use for PrimLiterals. They never have source text so we always drop them +-- | Captures a Numeric Literals Location, Source Text, and Value. +data Literal = IntLiteral LiteralSrcSpan Text Integer + | FracLiteral LiteralSrcSpan Text Rational + deriving (GHC.Generic, Show, Ord, Eq, Data) + +newtype LiteralSrcSpan = LiteralSrcSpan { unLit :: RealSrcSpan } + deriving (GHC.Generic, Show, Ord, Eq, Data) + +instance NFData LiteralSrcSpan where + rnf x = x `seq` () + +instance NFData Literal + + +-- | Return a Literal's Source representation +getSrcText :: Literal -> Text +getSrcText = \case + IntLiteral _ txt _ -> txt + FracLiteral _ txt _ -> txt + +-- | Return a Literal's Real Source location +getSrcSpan :: Literal -> RealSrcSpan +getSrcSpan = \case + IntLiteral ss _ _ -> unLit ss + FracLiteral ss _ _ -> unLit ss + +-- | Find all literals in a Parsed Source File +collectLiterals :: Data ast => ast -> [Literal] +collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern)) + + +-- | Translate from HsLit and HsOverLit Types to our Literal Type +getLiteral :: LHsExpr GhcPs -> Maybe Literal +getLiteral (L (locA -> (RealSrcSpan sSpan _)) expr) = case expr of + HsLit _ lit -> fromLit lit sSpan + HsOverLit _ overLit -> fromOverLit overLit sSpan + _ -> Nothing +getLiteral _ = Nothing + +-- | Destructure Patterns to unwrap any Literals +getPattern :: LPat GhcPs -> Maybe Literal +getPattern (L (locA -> (RealSrcSpan patSpan _)) pat) = case pat of + LitPat _ lit -> case lit of + HsInt _ val -> fromIntegralLit patSpan val + HsRat _ val _ -> fromFractionalLit patSpan val + _ -> Nothing +#if __GLASGOW_HASKELL__ == 902 + NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan + NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan +#else + NPat _ (L (locA -> (RealSrcSpan sSpan _)) overLit) _ _ -> fromOverLit overLit sSpan + NPlusKPat _ _ (L (locA -> (RealSrcSpan sSpan _)) overLit1) _ _ _ -> fromOverLit overLit1 sSpan +#endif + _ -> Nothing +getPattern _ = Nothing + +fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal +fromLit lit sSpan = case lit of + HsInt _ val -> fromIntegralLit sSpan val + HsRat _ val _ -> fromFractionalLit sSpan val + _ -> Nothing + +fromOverLit :: HsOverLit p -> RealSrcSpan -> Maybe Literal +fromOverLit OverLit{..} sSpan = case ol_val of + HsIntegral il -> fromIntegralLit sSpan il + HsFractional fl -> fromFractionalLit sSpan fl + _ -> Nothing +fromOverLit _ _ = Nothing + +fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal +fromIntegralLit s IL{..} = fmap (\txt' -> IntLiteral (LiteralSrcSpan s) txt' il_value) (fromSourceText il_text) + +fromFractionalLit :: RealSrcSpan -> FractionalLit -> Maybe Literal +fromFractionalLit s fl@FL{fl_text} = fmap (\txt' -> FracLiteral (LiteralSrcSpan s) txt' (rationalFromFractionalLit fl)) (fromSourceText fl_text) + +fromSourceText :: SourceText -> Maybe Text +fromSourceText = \case +#if __GLASGOW_HASKELL__ >= 908 + SourceText s -> Just $ T.decodeUtf8 $ bytesFS s +#else + SourceText s -> Just $ T.pack s +#endif + NoSourceText -> Nothing diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ViewPatterns #-} +module Main ( main ) where + +import Data.Either (rights) +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat +import qualified Ide.Plugin.Conversion as Conversion +import Properties.Conversion (conversions) +import System.FilePath ((<.>), ()) +import Test.Hls +import Text.Regex.TDFA ((=~)) + +main :: IO () +main = defaultTestRunner test + +alternateNumberFormatPlugin :: PluginTestDescriptor AlternateNumberFormat.Log +alternateNumberFormatPlugin = mkPluginTestDescriptor AlternateNumberFormat.descriptor "alternateNumberFormat" + +-- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time. +-- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something +-- to do with how +test :: TestTree +test = testGroup "alternateNumberFormat" [ + codeActionHex "TIntDtoH" 3 13 + , codeActionOctal "TIntDtoO" 3 13 + , codeActionBinary "TIntDtoB" 4 13 + , codeActionNumDecimal "TIntDtoND" 5 13 + , codeActionFracExp "TFracDtoE" 3 13 + , codeActionFloatHex "TFracDtoHF" 4 13 + , codeActionDecimal "TIntHtoD" 3 13 + , codeActionDecimal "TFracHFtoD" 4 13 + -- to test we don't duplicate pragmas + , codeActionFloatHex "TFracDtoHFWithPragma" 4 13 + , codeActionProperties "TFindLiteralIntPattern" [(4, 25), (5,25)] $ \actions -> do + liftIO $ length actions @?= 8 + , codeActionProperties "TFindLiteralIntCase" [(4, 29)] $ \actions -> do + liftIO $ length actions @?= 4 + , codeActionProperties "TFindLiteralIntCase2" [(5, 21)] $ \actions -> do + liftIO $ length actions @?= 4 + , codeActionProperties "TFindLiteralDoReturn" [(6, 10)] $ \actions -> do + liftIO $ length actions @?= 4 + , codeActionProperties "TFindLiteralDoLet" [(6, 13), (7, 13)] $ \actions -> do + liftIO $ length actions @?= 8 + , codeActionProperties "TFindLiteralList" [(4, 28)] $ \actions -> do + liftIO $ length actions @?= 4 + , conversions + ] + +codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree +codeActionProperties fp locs assertions = testCase fp $ do + runSessionWithServer def alternateNumberFormatPlugin testDataDir $ do + openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findAlternateNumberActions >>= assertions + where + -- similar to codeActionTest + codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs + +findAlternateNumberActions :: [Command |? CodeAction] -> Session [CodeAction] +findAlternateNumberActions = pure . filter isAlternateNumberCodeAction . rights . map toEither + where + isAlternateNumberCodeAction CodeAction{_kind} = case _kind of + Nothing -> False + Just kind -> case kind of + CodeActionKind_Custom txt -> txt == "quickfix.literals.style" + _ -> False + +-- most helpers derived from explicit-imports-plugin Main Test file + +testDataDir :: FilePath +testDataDir = "plugins" "hls-alternate-number-format-plugin" "test" "testdata" + +goldenAlternateFormat :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenAlternateFormat fp = goldenWithHaskellDoc def alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" + +codeActionTest :: (Maybe Text -> Bool) -> FilePath -> Int -> Int -> TestTree +codeActionTest filter' fp line col = goldenAlternateFormat fp $ \doc -> do + actions <- getCodeActions doc (pointRange line col) + -- can't generate code actions? + case find (filter' . codeActionTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionDecimal :: FilePath -> Int -> Int -> TestTree +codeActionDecimal = codeActionTest isDecimalCodeAction + +codeActionHex :: FilePath -> Int -> Int -> TestTree +codeActionHex = codeActionTest isHexCodeAction + +codeActionOctal :: FilePath -> Int -> Int -> TestTree +codeActionOctal = codeActionTest isOctalCodeAction + +codeActionBinary :: FilePath -> Int -> Int -> TestTree +codeActionBinary = codeActionTest isBinaryCodeAction + +codeActionNumDecimal :: FilePath -> Int -> Int -> TestTree +codeActionNumDecimal = codeActionTest isNumDecimalCodeAction + +codeActionFracExp :: FilePath -> Int -> Int -> TestTree +codeActionFracExp = codeActionTest isNumDecimalCodeAction + +codeActionFloatHex :: FilePath -> Int -> Int -> TestTree +codeActionFloatHex = codeActionTest isHexFloatCodeAction + +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle (InR CodeAction {_title}) = Just _title +codeActionTitle _ = Nothing + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) + +convertPrefix, intoInfix, maybeExtension, hexRegex, hexFloatRegex, binaryRegex, octalRegex, numDecimalRegex, decimalRegex :: Text +convertPrefix = "Convert (" <> T.intercalate "|" [Conversion.hexRegex, Conversion.hexFloatRegex, Conversion.binaryRegex, Conversion.octalRegex, Conversion.numDecimalRegex, Conversion.decimalRegex] <> ")" +intoInfix = " into " +maybeExtension = "( \\(needs extension: .*)?" +hexRegex = intoInfix <> Conversion.hexRegex <> maybeExtension +hexFloatRegex = intoInfix <> Conversion.hexFloatRegex <> maybeExtension +binaryRegex = intoInfix <> Conversion.binaryRegex <> maybeExtension +octalRegex = intoInfix <> Conversion.octalRegex <> maybeExtension +numDecimalRegex = intoInfix <> Conversion.numDecimalRegex <> maybeExtension +decimalRegex = intoInfix <> Conversion.decimalRegex <> maybeExtension + +isCodeAction :: Text -> Maybe Text -> Bool +isCodeAction userRegex (Just txt) = txt =~ Conversion.matchLineRegex (convertPrefix <> userRegex) +isCodeAction _ _ = False + +isHexCodeAction :: Maybe Text -> Bool +isHexCodeAction = isCodeAction hexRegex + +isHexFloatCodeAction :: Maybe Text -> Bool +isHexFloatCodeAction = isCodeAction hexFloatRegex + +isBinaryCodeAction :: Maybe Text -> Bool +isBinaryCodeAction = isCodeAction binaryRegex + +isOctalCodeAction :: Maybe Text -> Bool +isOctalCodeAction = isCodeAction octalRegex + +-- This can match EITHER an integer as NumDecimal extension or a Fractional +-- as in 1.23e-3 (so anything with an exponent really) +isNumDecimalCodeAction :: Maybe Text -> Bool +isNumDecimalCodeAction = isCodeAction numDecimalRegex + +isDecimalCodeAction :: Maybe Text -> Bool +isDecimalCodeAction = isCodeAction decimalRegex diff --git a/plugins/hls-alternate-number-format-plugin/test/Properties/Conversion.hs b/plugins/hls-alternate-number-format-plugin/test/Properties/Conversion.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/Properties/Conversion.hs @@ -0,0 +1,42 @@ +module Properties.Conversion where + +import Ide.Plugin.Conversion +import Test.Hls (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Regex.TDFA ((=~)) + +conversions :: TestTree +conversions = testGroup "Conversions" $ + map (uncurry testProperty) + [ ("Match NumDecimal", prop_regexMatchesNumDecimal) + , ("Match Hex", prop_regexMatchesHex) + , ("Match Octal", prop_regexMatchesOctal) + , ("Match Binary", prop_regexMatchesBinary) + ] + <> + map (uncurry testProperty) + [ ("Match HexFloat", prop_regexMatchesHexFloat) + , ("Match FloatDecimal", prop_regexMatchesFloatDecimal) + , ("Match FloatExpDecimal", prop_regexMatchesFloatExpDecimal) + ] + +prop_regexMatchesNumDecimal :: Integer -> Bool +prop_regexMatchesNumDecimal = (=~ numDecimalRegex) . toFloatExpDecimal @Double . fromInteger + +prop_regexMatchesHex :: Integer -> Bool +prop_regexMatchesHex = (=~ hexRegex ) . toHex + +prop_regexMatchesOctal :: Integer -> Bool +prop_regexMatchesOctal = (=~ octalRegex) . toOctal + +prop_regexMatchesBinary :: Integer -> Bool +prop_regexMatchesBinary = (=~ binaryRegex) . toBinary + +prop_regexMatchesHexFloat :: Double -> Bool +prop_regexMatchesHexFloat = (=~ hexFloatRegex) . toHexFloat + +prop_regexMatchesFloatDecimal :: Double -> Bool +prop_regexMatchesFloatDecimal = (=~ decimalRegex ) . toFloatDecimal + +prop_regexMatchesFloatExpDecimal :: Double -> Bool +prop_regexMatchesFloatExpDecimal = (=~ numDecimalRegex ) . toFloatExpDecimal diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralDoLet where + +doLet :: IO () +doLet = do + let x = 199 + y = 144 + pure () diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralDoReturn where + +doReturn :: IO Integer +doReturn = do + pure 54 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralIntCase where + +caseExpression x = case x + 34 of + _ -> "testing if we find a literal in the case statement" diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralIntCase where + +caseExpression x = case x of + 57 -> "testing to find literals in matching cases" + _ -> "" diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralIntPattern where + +patternMatchingFunction 1 = "one" +patternMatchingFunction 2 = "two" +patternMatchingFunction _ = "the rest of the numbers" diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} +module TFindLiteralList where + +listTest = [reverse $ show 57] diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.expected.hs @@ -0,0 +1,3 @@ +module TFracDtoE where + +convertMe = 1.2345e2 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoE.hs @@ -0,0 +1,3 @@ +module TFracDtoE where + +convertMe = 123.45 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHF where + +convertMe = 0x1.edccccccccccdp6 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHF.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Haskell2010 #-} +module TFracDtoHF where + +convertMe = 123.45 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.expected.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHFWithPragma where + +convertMe = 0x1.edccccccccccdp6 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracDtoHFWithPragma.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHFWithPragma where + +convertMe = 123.45 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.expected.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHF where + +convertMe = 123.45 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFracHFtoD.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHF where + +convertMe = 0x1.edccccccccccdp6 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE BinaryLiterals #-} +module TIntDtoB where + +convertMe = 0b1100 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoB.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Haskell2010 #-} +module TIntDtoB where + +convertMe = 12 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.expected.hs @@ -0,0 +1,3 @@ +module TIntDtoH where + +convertMe = 0xC diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoH.hs @@ -0,0 +1,3 @@ +module TIntDtoH where + +convertMe = 12 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE NumDecimals #-} +module TIntDtoND where + +convertMe :: Integer +convertMe = 1.25345e5 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoND.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Haskell2010 #-} +module TIntDtoND where + +convertMe :: Integer +convertMe = 125345 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.expected.hs @@ -0,0 +1,3 @@ +module TIntDtoO where + +convertMe = 0o14 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntDtoO.hs @@ -0,0 +1,3 @@ +module TIntDtoO where + +convertMe = 12 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.expected.hs @@ -0,0 +1,3 @@ +module TIntDtoH where + +convertMe = 12 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TIntHtoD.hs @@ -0,0 +1,3 @@ +module TIntDtoH where + +convertMe = 0xC diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/hie.yaml b/plugins/hls-alternate-number-format-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/hie.yaml @@ -0,0 +1,25 @@ +cradle: + direct: + arguments: + - -i + - -i. + - TIntDtoH + - TIntDtoB + - TIntDtoO + - TIntDtoND + - TFracDtoE + - TFracDtoHF + - TFracDtoHFWithPragma + - TIntHtoD + - TFracHFtoD + - TFindLiteralIntPattern + - TFindLiteralIntCase + - TFindLiteralIntCase2 + - TFindLiteralDoReturn + - TFindLiteralDoLet + - TFindLiteralList + - TExpectNoBinaryFormat + - TExpectBinaryFormat + - TExpectNoHexFloatFormat + - TExpectHexFloatFormat + - -Wall diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NumDecimals #-} +module TIntDtoND where + +convertMe :: Integer +convertMe = 125.345e3 diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalFmt where + +import Control.Lens +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams)) +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types +import Prelude hiding (log) +import System.Directory +import System.Exit +import System.FilePath +import System.Process.ListLike +import qualified System.Process.Text as Process + +data Log + = LogProcessInvocationFailure Int + | LogReadCreateProcessInfo T.Text [String] + | LogInvalidInvocationInfo + | LogCabalFmtNotFound + deriving (Show) + +instance Pretty Log where + pretty = \case + LogProcessInvocationFailure exitCode -> "Invocation of cabal-fmt failed with code" <+> pretty exitCode + LogReadCreateProcessInfo stdErrorOut args -> + vcat $ + ["Invocation of cabal-fmt with arguments" <+> pretty args] + ++ ["failed with standard error:" <+> pretty stdErrorOut | not (T.null stdErrorOut)] + LogInvalidInvocationInfo -> "Invocation of cabal-fmt with range was called but is not supported." + LogCabalFmtNotFound -> "Couldn't find executable 'cabal-fmt'" + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultCabalPluginDescriptor plId "Provides formatting of cabal files with cabal-fmt") + { pluginHandlers = mkFormattingHandlers (provider recorder) + } + +-- | Formatter provider of cabal fmt. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState +provider recorder _ _ (FormatRange _) _ _ _ = do + logWith recorder Info LogInvalidInvocationInfo + throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt." +provider recorder _ide _ FormatText contents nfp opts = do + let cabalFmtArgs = [ "--indent", show tabularSize] + x <- liftIO $ findExecutable "cabal-fmt" + case x of + Just _ -> do + (exitCode, out, err) <- + liftIO $ Process.readCreateProcessWithExitCode + ( proc "cabal-fmt" cabalFmtArgs + ) + { cwd = Just $ takeDirectory fp + } + contents + log Debug $ LogReadCreateProcessInfo err cabalFmtArgs + case exitCode of + ExitFailure code -> do + log Error $ LogProcessInvocationFailure code + throwError (PluginInternalError "Failed to invoke cabal-fmt") + ExitSuccess -> do + let fmtDiff = makeDiffTextEdit contents out + pure $ InL fmtDiff + Nothing -> do + log Error LogCabalFmtNotFound + throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.") + where + fp = fromNormalizedFilePath nfp + tabularSize = opts ^. L.tabSize + log = logWith recorder diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import qualified Ide.Plugin.CabalFmt as CabalFmt +import System.Directory (findExecutable) +import System.FilePath +import Test.Hls + +data CabalFmtFound = Found | NotFound + +isTestIsolated :: Bool +#if isolateTests +isTestIsolated = True +#else +isTestIsolated = False +#endif + +isCabalFmtFound :: IO CabalFmtFound +isCabalFmtFound = case isTestIsolated of + True -> pure Found + False-> do + cabalFmt <- findExecutable "cabal-fmt" + pure $ maybe NotFound (const Found) cabalFmt + +main :: IO () +main = do + foundCabalFmt <- isCabalFmtFound + defaultTestRunner (tests foundCabalFmt) + +cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log +cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt" + +tests :: CabalFmtFound -> TestTree +tests found = testGroup "cabal-fmt" + [ knownBrokenOnWindows "Eats newlines between comments" $ + cabalFmtGolden found "formats a simple document" "simple_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) + + , expectFailBecause "cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking issue: https://github.com/phadej/cabal-fmt/pull/82" $ + cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) + + , cabalFmtGolden found "formats a document with lib information" "lib_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 10 True Nothing Nothing Nothing) + ] + +cabalFmtGolden :: CabalFmtFound -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +cabalFmtGolden NotFound title _ _ _ = + testCase title $ + assertFailure $ "Couldn't find cabal-fmt on PATH or this is not an isolated run. " + <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally." +cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter def cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act + where + conf = def + +testDataDir :: FilePath +testDataDir = "plugins" "hls-cabal-fmt-plugin" "test" "testdata" diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.cabal @@ -0,0 +1,12 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Banana +extra-source-files: CHANGELOG.md + +library + -- cabal-fmt: expand src + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Banana +extra-source-files: CHANGELOG.md + +library + -- cabal-fmt: expand src + exposed-modules: + MyLib + MyOtherLib + + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/hie.yaml b/plugins/hls-cabal-fmt-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Gregg +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 + +executable testdata + main-is: Main.hs + build-depends: + base ^>=4.14.1.0,testdata + hs-source-dirs: app + default-language: + Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.formatted_document.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/lib_testdata.formatted_document.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Gregg +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 + +executable testdata + main-is: Main.hs + build-depends: + , base ^>=4.14.1.0 + , testdata + + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Milky + +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable testdata + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.formatted_document.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/simple_testdata.formatted_document.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Milky + +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable testdata + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyLib.hs b/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyOtherLib.hs b/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyOtherLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/src/MyOtherLib.hs @@ -0,0 +1,3 @@ +module MyOtherLib where + +bar = 2 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal (descriptor, Log (..)) where + +import Control.Concurrent.STM +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Lens ((^.)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NE +import qualified Data.Text.Encoding as Encoding +import Data.Typeable +import Development.IDE as D +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (alwaysRerun) +import qualified Development.IDE.Plugin.Completions.Logic as Ghcide +import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import GHC.Generics +import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes +import qualified Ide.Plugin.Cabal.Completion.Completions as Completions +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics +import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import qualified Ide.Plugin.Cabal.Parse as Parse +import Ide.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import Language.LSP.Server (getVirtualFile) +import qualified Language.LSP.VFS as VFS + +data Log + = LogModificationTime NormalizedFilePath FileVersion + | LogShake Shake.Log + | LogDocOpened Uri + | LogDocModified Uri + | LogDocSaved Uri + | LogDocClosed Uri + | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogCompletionContext Types.Context Position + | LogCompletions Types.Log + deriving (Show) + +instance Pretty Log where + pretty = \case + LogShake log' -> pretty log' + LogModificationTime nfp modTime -> + "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) + LogDocOpened uri -> + "Opened text document:" <+> pretty (getUri uri) + LogDocModified uri -> + "Modified text document:" <+> pretty (getUri uri) + LogDocSaved uri -> + "Saved text document:" <+> pretty (getUri uri) + LogDocClosed uri -> + "Closed text document:" <+> pretty (getUri uri) + LogFOI files -> + "Set files of interest to:" <+> viaShow files + LogCompletionContext context position -> + "Determined completion context:" + <+> viaShow context + <+> "for cursor position:" + <+> pretty position + LogCompletions logs -> pretty logs + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultCabalPluginDescriptor plId "Provides a variety of IDE features in cabal files") + { pluginRules = cabalRules recorder plId + , pluginHandlers = + mconcat + [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction + , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder + ] + , pluginNotificationHandlers = + mconcat + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ + \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocOpened _uri + addFileOfInterest recorder ide file Modified{firstOpen = True} + restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ + \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocModified _uri + addFileOfInterest recorder ide file Modified{firstOpen = False} + restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ + \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocSaved _uri + addFileOfInterest recorder ide file OnDisk + restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ + \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocClosed _uri + deleteFileOfInterest recorder ide file + restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" + ] + , pluginConfigDescriptor = defaultConfigDescriptor + { configHasDiagnostics = True + } + } + where + log' = logWith recorder + + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () + whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' + +{- | Helper function to restart the shake session, specifically for modifying .cabal files. +No special logic, just group up a bunch of functions you need for the base +Notification Handlers. + +To make sure diagnostics are up to date, we need to tell shake that the file was touched and +needs to be re-parsed. That's what we do when we record the dirty key that our parsing +rule depends on. +Then we restart the shake session, so that changes to our virtual files are actually picked up. +-} +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () +restartCabalShakeSession shakeExtras vfs file actionMsg = do + join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] + +-- ---------------------------------------------------------------- +-- Plugin Rules +-- ---------------------------------------------------------------- + +cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalRules recorder plId = do + -- Make sure we initialise the cabal files-of-interest. + ofInterestRules recorder + -- Rule to produce diagnostics for cabal files. + define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do + config <- getPluginConfigAction plId + if not (plcGlobalOn config && plcDiagnosticsOn config) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents + let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + case pm of + Left (_cabalVersion, pErrorNE) -> do + let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE + allDiags = errorDiags <> warningDiags + pure (allDiags, Nothing) + Right gpd -> do + pure (warningDiags, Just gpd) + + action $ do + -- Run the cabal kick. This code always runs when 'shakeRestart' is run. + -- Must be careful to not impede the performance too much. Crucial to + -- a snappy IDE experience. + kick + where + log' = logWith recorder + +{- | This is the kick function for the cabal plugin. +We run this action, whenever we shake session us run/restarted, which triggers +actions to produce diagnostics for cabal files. + +It is paramount that this kick-function can be run quickly, since it is a blocking +function invocation. +-} +kick :: Action () +kick = do + files <- HashMap.keys <$> getCabalFilesOfInterestUntracked + void $ uses Types.GetCabalDiagnostics files + +-- ---------------------------------------------------------------- +-- Code Actions +-- ---------------------------------------------------------------- + +licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = + pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) + +-- ---------------------------------------------------------------- +-- Cabal file of Interest rules and global variable +-- ---------------------------------------------------------------- + +{- | Cabal files that are currently open in the lsp-client. +Specific actions happen when these files are saved, closed or modified, +such as generating diagnostics, re-parsing, etc... + +We need to store the open files to parse them again if we restart the shake session. +Restarting of the shake session happens whenever these files are modified. +-} +newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance Shake.IsIdeGlobal OfInterestCabalVar + +data IsCabalFileOfInterest = IsCabalFileOfInterest + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsCabalFileOfInterest +instance NFData IsCabalFileOfInterest + +type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult + +data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus + deriving (Eq, Show, Typeable, Generic) +instance Hashable CabalFileOfInterestResult +instance NFData CabalFileOfInterestResult + +{- | The rule that initialises the files of interest state. + +Needs to be run on start-up. +-} +ofInterestRules :: Recorder (WithPriority Log) -> Rules () +ofInterestRules recorder = do + Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do + alwaysRerun + filesOfInterest <- getCabalFilesOfInterestUntracked + let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotCabalFOI = BS.singleton 0 + summarize (IsCabalFOI OnDisk) = BS.singleton 1 + summarize (IsCabalFOI (Modified False)) = BS.singleton 2 + summarize (IsCabalFOI (Modified True)) = BS.singleton 3 + +getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalFilesOfInterestUntracked = do + OfInterestCabalVar var <- Shake.getIdeGlobalAction + liftIO $ readVar var + +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest recorder state f v = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + (prev, files) <- modifyVar var $ \dict -> do + let (prev, new) = HashMap.alterF (,Just v) f dict + pure (new, (prev, new)) + when (prev /= Just v) $ do + join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + log' Debug $ LogFOI files + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest recorder state f = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + log' Debug $ LogFOI files + where + log' = logWith recorder + +-- ---------------------------------------------------------------- +-- Completion +-- ---------------------------------------------------------------- + +completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion +completion recorder ide _ complParams = do + let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument + position = complParams ^. JL.position + contents <- lift $ getVirtualFile $ toNormalizedUri uri + case (contents, uriToFilePath' uri) of + (Just cnts, Just path) -> do + let pref = Ghcide.getCompletionPrefix position cnts + let res = result pref path cnts + liftIO $ fmap InL res + _ -> pure . InR $ InR Null + where + result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem] + result prefix fp cnts = do + runMaybeT context >>= \case + Nothing -> pure [] + Just ctx -> do + logWith recorder Debug $ LogCompletionContext ctx pos + let completer = Completions.contextToCompleter ctx + let completerData = CompleterTypes.CompleterData + { getLatestGPD = do + mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp + pure $ fmap fst mGPD + , cabalPrefixInfo = prefInfo + , stanzaName = + case fst ctx of + Types.Stanza _ name -> name + _ -> Nothing + } + completions <- completer completerRecorder completerData + pure completions + where + completerRecorder = cmapWithPrio LogCompletions recorder + pos = Ghcide.cursorPos prefix + context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text) + prefInfo = Completions.getCabalPrefixInfo fp prefix diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE LambdaCase #-} + +module Ide.Plugin.Cabal.Completion.Completer.FilePath where + +import Control.Exception (evaluate, try) +import Control.Monad (filterM) +import Control.Monad.Extra (concatForM, forM) +import qualified Data.Text as T +import Distribution.PackageDescription (GenericPackageDescription) +import Ide.Logger +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types +import Ide.Plugin.Cabal.Completion.Types +import System.Directory (doesDirectoryExist, + doesFileExist, + listDirectory) +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as Posix +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | Completer to be used when a file path can be completed for a field. +-- Completes file paths as well as directories. +filePathCompleter :: Completer +filePathCompleter recorder cData = do + let prefInfo = cabalPrefixInfo cData + complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo + filePathCompletions <- listFileCompletions recorder complInfo + let scored = + Fuzzy.simpleFilter + Fuzzy.defChunkSize + Fuzzy.defMaxResults + (pathSegment complInfo) + (map T.pack filePathCompletions) + forM + scored + ( \compl' -> do + let compl = Fuzzy.original compl' + fullFilePath <- mkFilePathCompletion complInfo compl + pure $ mkCompletionItem (completionRange prefInfo) fullFilePath fullFilePath + ) + +mainIsCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer +mainIsCompleter extractionFunction recorder cData = do + mGPD <- getLatestGPD cData + case mGPD of + Just gpd -> do + let srcDirs = extractionFunction sName gpd + concatForM srcDirs + (\dir' -> do + let dir = FP.normalise dir' + let pathInfo = pathCompletionInfoFromCabalPrefixInfo dir prefInfo + completions <- listFileCompletions recorder pathInfo + let scored = Fuzzy.simpleFilter + Fuzzy.defChunkSize + Fuzzy.defMaxResults + (pathSegment pathInfo) + (map T.pack completions) + forM + scored + ( \compl' -> do + let compl = Fuzzy.original compl' + fullFilePath <- mkFilePathCompletion pathInfo compl + pure $ mkCompletionItem (completionRange prefInfo) fullFilePath fullFilePath + ) + ) + Nothing -> do + logWith recorder Debug LogUseWithStaleFastNoResult + pure [] + where + sName = stanzaName cData + prefInfo = cabalPrefixInfo cData + + +-- | Completer to be used when a directory can be completed for the field. +-- Only completes directories. +directoryCompleter :: Completer +directoryCompleter recorder cData = do + let prefInfo = cabalPrefixInfo cData + complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo + directoryCompletions <- listDirectoryCompletions recorder complInfo + let scored = + Fuzzy.simpleFilter + Fuzzy.defChunkSize + Fuzzy.defMaxResults + (pathSegment complInfo) + (map T.pack directoryCompletions) + forM + scored + ( \compl' -> do + let compl = Fuzzy.original compl' + let fullDirPath = mkPathCompletionDir complInfo compl + pure $ mkCompletionItem (completionRange prefInfo) fullDirPath fullDirPath + ) + +{- Note [Using correct file path separators] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Since cabal files only allow for posix style file paths + we need to be careful to use the correct path separators + whenever we work with file paths in cabal files. + + Thus we are using two different kinds of imports. + We use "FP" for platform-compatible file paths with which + we can query files independently of the platform. + We use "Posix" for the posix syntax paths which need to + be used for file path completions to be written to the cabal file. +-} + +-- | Takes a PathCompletionInfo and returns the list of files and directories +-- in the directory which match the path completion info in posix style. +-- +-- The directories end with a posix trailing path separator. +-- Since this is used for completions to be written to the cabal file, +-- we use posix separators here. +-- See Note [Using correct file path separators]. +listFileCompletions :: Recorder (WithPriority Log) -> PathCompletionInfo -> IO [FilePath] +listFileCompletions recorder complInfo = do + let complDir = mkCompletionDirectory complInfo + try (evaluate =<< listDirectory complDir) >>= \case + Right dirs -> do + forM dirs $ \d -> do + isDir <- doesDirectoryExist $ mkDirFromCWD complInfo d + pure $ if isDir then Posix.addTrailingPathSeparator d else d + Left (err :: IOError) -> do + logWith recorder Warning $ LogFilePathCompleterIOError complDir err + pure [] + +-- | Returns a list of all (and only) directories in the +-- directory described by path completion info. +listDirectoryCompletions :: Recorder (WithPriority Log) -> PathCompletionInfo -> IO [FilePath] +listDirectoryCompletions recorder complInfo = do + filepaths <- listFileCompletions recorder complInfo + filterM (doesDirectoryExist . mkDirFromCWD complInfo) filepaths + +-- | Returns the directory where files and directories can be queried from +-- for the passed PathCompletionInfo. +-- +-- Returns the full path to the directory pointed to by the path prefix +-- by combining it with the working directory. +-- +-- Since this is used for querying paths we use platform +-- compatible separators here. +-- See Note [Using correct file path separators]. +mkCompletionDirectory :: PathCompletionInfo -> FilePath +mkCompletionDirectory complInfo = + FP.addTrailingPathSeparator $ + workingDirectory complInfo FP. (FP.normalise $ queryDirectory complInfo) + +-- | Returns the full path for the given path segment +-- by combining the working directory with the path prefix +-- and the path segment. +-- +-- Since this is used for querying paths we use platform +-- compatible separators here. +-- See Note [Using correct file path separators]. +mkDirFromCWD :: PathCompletionInfo -> FilePath -> FilePath +mkDirFromCWD complInfo fp = + FP.addTrailingPathSeparator $ + mkCompletionDirectory complInfo FP. FP.normalise fp + +-- | Takes a PathCompletionInfo and a directory and +-- returns the complete cabal path to be written on completion action +-- by combining the previously written path prefix and the completed +-- path segment. +-- +-- Since this is used for completions we use posix separators here. +-- See Note [Using correct file path separators]. +mkPathCompletionDir :: PathCompletionInfo -> T.Text -> T.Text +mkPathCompletionDir complInfo completion = + T.pack $ + queryDirectory complInfo Posix. T.unpack completion + +-- | Takes a PathCompletionInfo and a completed path segment and +-- generates the whole filepath to be completed. +-- +-- The returned text combines the completion with a relative path +-- generated from a possible previously written path prefix and +-- is relative to the cabal file location. +-- +-- If the completion results in a filepath, we know this is a +-- completed path and can thus apply wrapping of apostrophes if needed. +mkFilePathCompletion :: PathCompletionInfo -> T.Text -> IO T.Text +mkFilePathCompletion complInfo completion = do + let combinedPath = mkPathCompletionDir complInfo completion + isFilePath <- doesFileExist $ T.unpack combinedPath + let completedPath = if isFilePath then applyStringNotation (isStringNotationPath complInfo) combinedPath else combinedPath + pure completedPath diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Completion.Completer.Module where + +import Control.Monad (filterM) +import Control.Monad.Extra (concatForM, + forM) +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Distribution.PackageDescription (GenericPackageDescription) +import Ide.Logger (Priority (..), + Recorder, + WithPriority, + logWith) +import Ide.Plugin.Cabal.Completion.Completer.FilePath (listFileCompletions, + mkCompletionDirectory) +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types +import Ide.Plugin.Cabal.Completion.Types +import System.Directory (doesFileExist) +import qualified System.FilePath as FP +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | Completer to be used when module paths can be completed for the field. +-- +-- Takes an extraction function which extracts the source directories +-- to be used by the completer. +modulesCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer +modulesCompleter extractionFunction recorder cData = do + mGPD <- getLatestGPD cData + case mGPD of + Just gpd -> do + let sourceDirs = extractionFunction sName gpd + filePathCompletions <- + filePathsForExposedModules recorder sourceDirs prefInfo + pure $ map (\compl -> mkSimpleCompletionItem (completionRange prefInfo) compl) filePathCompletions + Nothing -> do + logWith recorder Debug LogUseWithStaleFastNoResult + pure [] + where + sName = stanzaName cData + prefInfo = cabalPrefixInfo cData + +-- | Takes a list of source directories and returns a list of path completions +-- relative to any of the passed source directories which fit the passed prefix info. +filePathsForExposedModules :: Recorder (WithPriority Log) -> [FilePath] -> CabalPrefixInfo -> IO [T.Text] +filePathsForExposedModules recorder srcDirs prefInfo = do + concatForM + srcDirs + ( \dir' -> do + let dir = FP.normalise dir' + pathInfo = pathCompletionInfoFromCabalPrefixInfo dir modPrefInfo + completions <- listFileCompletions recorder pathInfo + validExposedCompletions <- filterM (isValidExposedModulePath pathInfo) completions + let toMatch = pathSegment pathInfo + scored = Fuzzy.simpleFilter + Fuzzy.defChunkSize + Fuzzy.defMaxResults + toMatch + (map T.pack validExposedCompletions) + forM + scored + ( \compl' -> do + let compl = Fuzzy.original compl' + fullFilePath <- mkExposedModulePathCompletion pathInfo $ T.unpack compl + pure fullFilePath + ) + ) + where + prefix = + T.pack $ exposedModulePathToFp $ + completionPrefix prefInfo + -- build completion info relative to the source dir, + -- we overwrite the prefix written in the cabal file with its translation + -- to filepath syntax, since it is in exposed module syntax + modPrefInfo = prefInfo{completionPrefix=prefix} + + -- Takes a PathCompletionInfo and a path segment and checks whether + -- the path segment can be completed for an exposed module. + -- + -- This is the case if the segment represents either a directory or a Haskell file. + isValidExposedModulePath :: PathCompletionInfo -> FilePath -> IO Bool + isValidExposedModulePath pInfo path = do + let dir = mkCompletionDirectory pInfo + fileExists <- doesFileExist (dir FP. path) + pure $ not fileExists || FP.takeExtension path `elem` [".hs", ".lhs"] + +-- | Takes a pathCompletionInfo and a path segment and generates the whole +-- filepath to be written on completion including a possibly already written prefix; +-- using the cabal syntax for exposed modules. +-- +-- Examples: +-- When the partial directory path `Dir.Dir2.` is stored in the PathCompletionInfo +-- and the completed file `HaskellFile.hs` is passed along with that PathCompletionInfo, +-- the result would be `Dir1.Dir2.HaskellFile` +-- +-- When the partial directory path `Dir.` is stored in the PathCompletionInfo +-- and the completed directory `Dir2` is passed along with that PathCompletionInfo, +-- the result would be `Dir1.Dir2.` +mkExposedModulePathCompletion :: PathCompletionInfo -> FilePath -> IO T.Text +mkExposedModulePathCompletion complInfo completion = do + let combinedPath = queryDirectory complInfo FP. completion + isFilePath <- doesFileExist (workingDirectory complInfo FP. combinedPath) + let addTrailingDot modPath = if isFilePath then modPath else modPath <> "." + let exposedPath = FP.makeRelative "." combinedPath + pure $ addTrailingDot $ fpToExposedModulePath "" exposedPath + +-- | Takes a source directory path and a module path and returns +-- the module path relative to the source directory +-- in exposed module syntax where the separators are '.' +-- and the file ending is removed. +-- +-- Synopsis: @'fpToExposedModulePath' sourceDir modPath@. +fpToExposedModulePath :: FilePath -> FilePath -> T.Text +fpToExposedModulePath sourceDir modPath = + T.intercalate "." $ fmap T.pack $ FP.splitDirectories $ FP.dropExtension fp + where + fp = fromMaybe modPath $ stripPrefix sourceDir modPath + +-- | Takes a path in the exposed module syntax and translates it to a platform-compatible file path. +exposedModulePathToFp :: T.Text -> FilePath +exposedModulePathToFp fp = T.unpack $ T.replace "." (T.singleton FP.pathSeparator) fp diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs @@ -0,0 +1,118 @@ +module Ide.Plugin.Cabal.Completion.Completer.Paths where + +import qualified Data.List as List +import qualified Data.Text as T +import Distribution.PackageDescription (Benchmark (..), + BuildInfo (..), + CondTree (condTreeData), + Executable (..), + GenericPackageDescription (..), + Library (..), + UnqualComponentName, + mkUnqualComponentName, + testBuildInfo) +import Distribution.Utils.Path (getSymbolicPath) +import Ide.Plugin.Cabal.Completion.Types +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as Posix + + +{- | Information used to query and build path completions. + + Note that pathSegment combined with queryDirectory results in + the original prefix. + + Example: + When given the written prefix, @dir1\/dir2\/fi@, the + resulting PathCompletionInfo would be: + + @ + pathSegment = "fi" + queryDirectory = "dir1\/dir2\/fi" + ... + @ +-} +data PathCompletionInfo = PathCompletionInfo + { pathSegment :: T.Text, + -- ^ Partly written segment of the next part of the path. + queryDirectory :: FilePath, + -- ^ Written part of path, in posix format. + workingDirectory :: FilePath, + -- ^ Directory relative to which relative paths are interpreted, platform dependent. + isStringNotationPath :: Maybe Apostrophe + -- ^ Did the completion happen in the context of a string notation, + -- if yes, contains the state of the string notation. + } + deriving (Eq, Show) + +{- | Takes an optional source subdirectory and a prefix info + and creates a path completion info accordingly. + + The source directory represents some subdirectory of the working directory such as a + path from the field @hs-source-dirs@. + + If the source subdirectory is empty, then the working directory is simply set to + the currently handled cabal file's directory. +-} +pathCompletionInfoFromCabalPrefixInfo :: FilePath -> CabalPrefixInfo -> PathCompletionInfo +pathCompletionInfoFromCabalPrefixInfo srcDir prefInfo = + PathCompletionInfo + { pathSegment = T.pack pathSegment', + queryDirectory = queryDirectory', + workingDirectory = completionWorkingDir prefInfo FP. srcDir, + isStringNotationPath = isStringNotation prefInfo + } + where + prefix = T.unpack $ completionPrefix prefInfo + (queryDirectory', pathSegment') = Posix.splitFileName prefix + +-- | Extracts the source directories of the library stanza. +sourceDirsExtractionLibrary :: Maybe StanzaName -> GenericPackageDescription -> [FilePath] +sourceDirsExtractionLibrary Nothing gpd = + -- we use condLibrary to get the information contained in the library stanza + -- since the library in PackageDescription is not populated by us + case libM of + Just lib -> do + map getSymbolicPath $ hsSourceDirs $ libBuildInfo $ condTreeData lib + Nothing -> [] + where + libM = condLibrary gpd +sourceDirsExtractionLibrary name gpd = extractRelativeDirsFromStanza name gpd condSubLibraries libBuildInfo + +-- | Extracts the source directories of the executable stanza with the given name. +sourceDirsExtractionExecutable :: Maybe StanzaName -> GenericPackageDescription -> [FilePath] +sourceDirsExtractionExecutable name gpd = extractRelativeDirsFromStanza name gpd condExecutables buildInfo + +-- | Extracts the source directories of the test suite stanza with the given name. +sourceDirsExtractionTestSuite :: Maybe StanzaName -> GenericPackageDescription -> [FilePath] +sourceDirsExtractionTestSuite name gpd = extractRelativeDirsFromStanza name gpd condTestSuites testBuildInfo + +-- | Extracts the source directories of benchmark stanza with the given name. +sourceDirsExtractionBenchmark :: Maybe StanzaName -> GenericPackageDescription -> [FilePath] +sourceDirsExtractionBenchmark name gpd = extractRelativeDirsFromStanza name gpd condBenchmarks benchmarkBuildInfo + +{- | Takes a possible stanza name, a GenericPackageDescription, + a function to access the stanza information we are interested in + and a function to access the build info from the specific stanza. + + Returns a list of relative source directory paths specified for the extracted stanza. +-} +extractRelativeDirsFromStanza :: + Maybe StanzaName -> + GenericPackageDescription -> + (GenericPackageDescription -> [(UnqualComponentName, CondTree b c a)]) -> + (a -> BuildInfo) -> + [FilePath] +extractRelativeDirsFromStanza Nothing _ _ _ = [] +extractRelativeDirsFromStanza (Just name) gpd getStanza getBuildInfo + | Just stanza <- stanzaM = map getSymbolicPath $ hsSourceDirs $ getBuildInfo stanza + | otherwise = [] + where + stanzaM = fmap (condTreeData . snd) res + allStanzasM = getStanza gpd + res = + List.find + ( \(n, _) -> + n == mkUnqualComponentName (T.unpack name) + ) + allStanzasM diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Completion.Completer.Simple where + +import Control.Lens ((?~)) +import Data.Function ((&)) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Ord (Down (Down)) +import qualified Data.Text as T +import Ide.Logger (Priority (..), + logWith) +import Ide.Plugin.Cabal.Completion.Completer.Types +import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), + Log) +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Types as Compls (CompletionItem (..)) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | Completer to be used when no completion suggestions +-- are implemented for the field +noopCompleter :: Completer +noopCompleter _ _ = pure [] + +-- | Completer to be used when no completion suggestions +-- are implemented for the field and a log message should be emitted. +errorNoopCompleter :: Log -> Completer +errorNoopCompleter l recorder _ = do + logWith recorder Warning l + pure [] + +-- | Completer to be used when a simple set of values +-- can be completed for a field. +constantCompleter :: [T.Text] -> Completer +constantCompleter completions _ cData = do + let prefInfo = cabalPrefixInfo cData + scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) completions + range = completionRange prefInfo + pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored + +-- | Completer to be used for the field @name:@ value. +-- +-- This is almost always the name of the cabal file. However, +-- it is not forbidden by the specification to have a different name, +-- it is just forbidden on hackage. +nameCompleter :: Completer +nameCompleter _ cData = do + let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) [completionFileName prefInfo] + prefInfo = cabalPrefixInfo cData + range = completionRange prefInfo + pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored + +-- | Completer to be used when a set of values with priority weights +-- attached to some values are to be completed for a field. +-- +-- The higher the weight, the higher the priority to show +-- the value in the completion suggestion. +-- +-- If the value does not occur in the weighted map its weight is defaulted to zero. +weightedConstantCompleter :: [T.Text] -> Map T.Text Double -> Completer +weightedConstantCompleter completions weights _ cData = do + let scored = + if perfectScore > 0 + then + fmap Fuzzy.original $ + Fuzzy.simpleFilter' Fuzzy.defChunkSize Fuzzy.defMaxResults prefix completions customMatch + else topTenByWeight + range = completionRange prefInfo + pure $ map (mkSimpleCompletionItem range) scored + where + prefInfo = cabalPrefixInfo cData + prefix = completionPrefix prefInfo + -- The perfect score is the score of the word matched with itself + -- this should never return Nothing since we match the word with itself + perfectScore = fromMaybe (error "match is broken") $ Fuzzy.match prefix prefix + -- \| Since the best score is cut off at the perfect score, we use a custom match + -- which allows for the score to be larger than the perfect score. + -- + -- This is necessary since the weight is multiplied with the originally matched + -- score and thus the calculated score may be larger than the perfect score. + customMatch :: (T.Text -> T.Text -> Maybe Int) + customMatch toSearch searchSpace = do + matched <- Fuzzy.match toSearch searchSpace + let weight = fromMaybe 0 $ Map.lookup searchSpace weights + let score = + min + perfectScore + (round (fromIntegral matched * (1 + weight))) + pure score + -- \| Sorts the list in descending order based on the map of weights and then + -- returns the top ten items in the list + topTenByWeight :: [T.Text] + topTenByWeight = take 10 $ map fst $ List.sortOn (Down . snd) $ Map.assocs weights + +-- | Creates a CompletionItem with the given text as the label +-- where the completion item kind is keyword. +mkDefaultCompletionItem :: T.Text -> LSP.CompletionItem +mkDefaultCompletionItem label = + LSP.CompletionItem + { Compls._label = label, + Compls._labelDetails = Nothing, + Compls._kind = Just LSP.CompletionItemKind_Keyword, + Compls._tags = Nothing, + Compls._detail = Nothing, + Compls._documentation = Nothing, + Compls._deprecated = Nothing, + Compls._preselect = Nothing, + Compls._sortText = Nothing, + Compls._filterText = Nothing, + Compls._insertText = Nothing, + Compls._insertTextFormat = Nothing, + Compls._insertTextMode = Nothing, + Compls._textEdit = Nothing, + Compls._textEditText = Nothing, + Compls._additionalTextEdits = Nothing, + Compls._commitCharacters = Nothing, + Compls._command = Nothing, + Compls._data_ = Nothing + } + +-- | Returns a CompletionItem with the given starting position +-- and text to be inserted, where the displayed text is the same as the +-- inserted text. +mkSimpleCompletionItem :: LSP.Range -> T.Text -> LSP.CompletionItem +mkSimpleCompletionItem range txt = + mkDefaultCompletionItem txt + & JL.textEdit ?~ LSP.InL (LSP.TextEdit range txt) + +-- | Returns a completionItem with the given starting position, +-- text to be inserted and text to be displayed in the completion suggestion. +mkCompletionItem :: LSP.Range -> T.Text -> T.Text -> LSP.CompletionItem +mkCompletionItem range insertTxt displayTxt = + mkDefaultCompletionItem displayTxt + & JL.textEdit ?~ LSP.InL (LSP.TextEdit range insertTxt) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Completion.Completer.Snippet where + +import Control.Lens ((?~)) +import Control.Monad.Extra (mapMaybeM) +import Data.Function ((&)) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import Ide.Logger (Priority (..), + logWith) +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types +import Ide.Plugin.Cabal.Completion.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Types as LSP +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | Maps snippet triggerwords with their completers +snippetCompleter :: Completer +snippetCompleter recorder cData = do + let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) $ Map.keys snippets + mapMaybeM + ( \compl -> do + let matched = Fuzzy.original compl + let completion' = Map.lookup matched snippets + case completion' of + Nothing -> do + logWith recorder Warning $ LogMapLookUpOfKnownKeyFailed matched + pure Nothing + Just completion -> + pure $ Just $ mkSnippetCompletion completion matched + ) + scored + where + snippets = snippetMap prefInfo + prefInfo = cabalPrefixInfo cData + mkSnippetCompletion :: T.Text -> T.Text -> LSP.CompletionItem + mkSnippetCompletion insertText toDisplay = + mkDefaultCompletionItem toDisplay + & JL.kind ?~ LSP.CompletionItemKind_Snippet + & JL.insertText ?~ insertText + & JL.insertTextFormat ?~ LSP.InsertTextFormat_Snippet + +type TriggerWord = T.Text + +snippetMap :: CabalPrefixInfo -> Map TriggerWord T.Text +snippetMap prefInfo = + fmap T.unlines $ + Map.fromList + [ ( "library-snippet", + [ "library", + " hs-source-dirs: $1", + " exposed-modules: $2", + " build-depends: base", + " default-language: Haskell2010" + ] + ), + ( "recommended-fields", + [ "cabal-version: $1", + "name: " <> completionFileName prefInfo, + "version: 0.1.0.0", + "maintainer: $4", + "category: $5", + "synopsis: $6", + "license: $7", + "build-type: Simple" + ] + ), + ( "executable-snippet", + [ "executable $1", + " main-is: ${2:Main.hs}", + " build-depends: base" + ] + ), + ( "benchmark-snippet", + [ "benchmark $1", + " type: exitcode-stdio-1.0", + " main-is: ${3:Main.hs}", + " build-depends: base" + ] + ), + ( "testsuite-snippet", + [ "test-suite $1", + " type: exitcode-stdio-1.0", + " main-is: ${3:Main.hs}", + " build-depends: base" + ] + ), + ( "common-warnings", + [ "common warnings", + " ghc-options: -Wall" + ] + ), + ( "source-repo-github-snippet", + [ "source-repository head", + " type: git", + " location: git://github.com/$2" + ] + ), + ( "source-repo-git-snippet", + [ "source-repository head", + " type: git", + " location: $1" + ] + ) + ] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Completion.Completer.Types where + +import Development.IDE as D +import Distribution.PackageDescription (GenericPackageDescription) +import Ide.Plugin.Cabal.Completion.Types +import Language.LSP.Protocol.Types (CompletionItem) + +-- | Takes information needed to build possible completion items +-- and returns the list of possible completion items +type Completer = Recorder (WithPriority Log) -> CompleterData -> IO [CompletionItem] + +-- | Contains information to be used by completers. +data CompleterData = CompleterData + { -- | Access to the latest available generic package description for the handled cabal file, + -- relevant for some completion actions which require the file's meta information + -- such as the module completers which require access to source directories + getLatestGPD :: IO (Maybe GenericPackageDescription), + -- | Prefix info to be used for constructing completion items + cabalPrefixInfo :: CabalPrefixInfo, + -- | The name of the stanza in which the completer is applied + stanzaName :: Maybe StanzaName + } diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Completion.Completions (contextToCompleter, getContext, getCabalPrefixInfo) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Maybe +import Data.Foldable (asum) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Utf16.Lines as Rope (Position (..)) +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Snippet +import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Data +import Ide.Plugin.Cabal.Completion.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified System.FilePath as FP +import System.FilePath (takeBaseName) + +-- ---------------------------------------------------------------- +-- Public API for Completions +-- ---------------------------------------------------------------- + +-- | Takes information about the completion context within the file +-- and finds the correct completer to be applied. +contextToCompleter :: Context -> Completer +-- if we are in the top level of the cabal file and not in a keyword context, +-- we can write any top level keywords or a stanza declaration +contextToCompleter (TopLevel, None) = + snippetCompleter + <> ( constantCompleter $ + Map.keys (cabalVersionKeyword <> cabalKeywords) ++ Map.keys stanzaKeywordMap + ) +-- if we are in a keyword context in the top level, +-- we look up that keyword in the top level context and can complete its possible values +contextToCompleter (TopLevel, KeyWord kw) = + case Map.lookup kw (cabalVersionKeyword <> cabalKeywords) of + Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) + Just l -> l +-- if we are in a stanza and not in a keyword context, +-- we can write any of the stanza's keywords or a stanza declaration +contextToCompleter (Stanza s _, None) = + case Map.lookup s stanzaKeywordMap of + Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s) + Just l -> constantCompleter $ Map.keys l +-- if we are in a stanza's keyword's context we can complete possible values of that keyword +contextToCompleter (Stanza s _, KeyWord kw) = + case Map.lookup s stanzaKeywordMap of + Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s) + Just m -> case Map.lookup kw m of + Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) + Just l -> l + +-- | Takes prefix info about the previously written text +-- and a rope (representing a file), returns the corresponding context. +-- +-- Can return Nothing if an error occurs. +-- +-- TODO: first line can only have cabal-version: keyword +getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> Rope -> MaybeT m Context +getContext recorder prefInfo ls = + case prevLinesM of + Just prevLines -> do + let lvlContext = + if completionIndentation prefInfo == 0 + then TopLevel + else currentLevel prevLines + case lvlContext of + TopLevel -> do + kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines (cabalVersionKeyword <> cabalKeywords) + pure (TopLevel, kwContext) + Stanza s n -> + case Map.lookup s stanzaKeywordMap of + Nothing -> do + pure (Stanza s n, None) + Just m -> do + kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines m + pure (Stanza s n, kwContext) + Nothing -> do + logWith recorder Warning $ LogFileSplitError pos + -- basically returns nothing + fail "Abort computation" + where + pos = completionCursorPosition prefInfo + prevLinesM = splitAtPosition pos ls + +-- | Takes information about the current file's file path, +-- and the cursor position in the file; and builds a CabalPrefixInfo +-- with the prefix up to that cursor position. +-- Checks whether a suffix needs to be completed +-- and calculates the range in the document +-- where the completion action should be applied. +getCabalPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo +getCabalPrefixInfo fp prefixInfo = + CabalPrefixInfo + { completionPrefix = completionPrefix', + isStringNotation = mkIsStringNotation separator afterCursorText, + completionCursorPosition = Ghcide.cursorPos prefixInfo, + completionRange = Range completionStart completionEnd, + completionWorkingDir = FP.takeDirectory fp, + completionFileName = T.pack $ takeBaseName fp + } + where + completionEnd = Ghcide.cursorPos prefixInfo + completionStart = + Position + (_line completionEnd) + (_character completionEnd - (fromIntegral $ T.length completionPrefix')) + (beforeCursorText, afterCursorText) = T.splitAt cursorColumn $ Ghcide.fullLine prefixInfo + completionPrefix' = T.takeWhileEnd (not . (`elem` stopConditionChars)) beforeCursorText + separator = + -- if there is an opening apostrophe before the cursor in the line somewhere, + -- everything after that apostrophe is the completion prefix + if odd $ T.count "\"" beforeCursorText + then '\"' + else ' ' + cursorColumn = fromIntegral $ Ghcide.cursorPos prefixInfo ^. JL.character + stopConditionChars = separator : [',', ':'] + + -- \| Takes the character occurring exactly before, + -- and the text occurring after the item to be completed and + -- returns whether the item is already surrounded by apostrophes. + -- + -- Example: (@|@ indicates the cursor position) + -- + -- @"./src|@ would call @'\"'@ @""@ and result in Just LeftSide + -- + -- @"./src|"@ would call @'\"'@ @'\"'@ and result in Just Surrounded + -- + mkIsStringNotation :: Char -> T.Text -> Maybe Apostrophe + mkIsStringNotation '\"' restLine + | Just ('\"', _) <- T.uncons restLine = Just Surrounded + | otherwise = Just LeftSide + mkIsStringNotation _ _ = Nothing + +-- ---------------------------------------------------------------- +-- Implementation Details +-- ---------------------------------------------------------------- + +-- | Takes prefix info about the previously written text, +-- a list of lines (representing a file) and a map of +-- keywords and returns a keyword context if the +-- previously written keyword matches one in the map. +-- +-- From a cursor position, we traverse the cabal file upwards to +-- find the latest written keyword if there is any. +-- Values may be written on subsequent lines, +-- in order to allow for this we take the indentation of the current +-- word to be completed into account to find the correct keyword context. +getKeyWordContext :: CabalPrefixInfo -> [T.Text] -> Map KeyWordName a -> Maybe FieldContext +getKeyWordContext prefInfo ls keywords = do + case lastNonEmptyLineM of + Nothing -> Just None + Just lastLine' -> do + let (whiteSpaces, lastLine) = T.span (== ' ') lastLine' + let keywordIndentation = T.length whiteSpaces + let cursorIndentation = completionIndentation prefInfo + -- in order to be in a keyword context the cursor needs + -- to be indented more than the keyword + if cursorIndentation > keywordIndentation + then -- if the last thing written was a keyword without a value + case List.find (`T.isPrefixOf` lastLine) (Map.keys keywords) of + Nothing -> Just None + Just kw -> Just $ KeyWord kw + else Just None + where + lastNonEmptyLineM :: Maybe T.Text + lastNonEmptyLineM = do + (curLine, rest) <- List.uncons ls + -- represents the current line while disregarding the + -- currently written text we want to complete + let cur = stripPartiallyWritten curLine + List.find (not . T.null . T.stripEnd) $ + cur : rest + +-- | Traverse the given lines (starting before current cursor position +-- up to the start of the file) to find the nearest stanza declaration, +-- if none is found we are in the top level context. +-- +-- TODO: this could be merged with getKeyWordContext in order to increase +-- performance by reducing the number of times we have to traverse the cabal file. +currentLevel :: [T.Text] -> StanzaContext +currentLevel [] = TopLevel +currentLevel (cur : xs) + | Just (s, n) <- stanza = Stanza s n + | otherwise = currentLevel xs + where + stanza = asum $ map checkStanza (Map.keys stanzaKeywordMap) + checkStanza :: StanzaType -> Maybe (StanzaType, Maybe StanzaName) + checkStanza t = + case T.stripPrefix t (T.strip cur) of + Just n + | T.null n -> Just (t, Nothing) + | otherwise -> Just (t, Just $ T.strip n) + Nothing -> Nothing + +-- | Get all lines before the given cursor position in the given file +-- and reverse their order to traverse backwards starting from the given position. +splitAtPosition :: Position -> Rope -> Maybe [T.Text] +splitAtPosition pos ls = do + split <- splitFile + pure $ reverse $ Rope.lines $ fst split + where + splitFile = Rope.utf16SplitAtPosition ropePos ls + ropePos = + Rope.Position + { Rope.posLine = fromIntegral $ pos ^. JL.line, + Rope.posColumn = fromIntegral $ pos ^. JL.character + } + +-- | Takes a line of text and removes the last partially +-- written word to be completed. +stripPartiallyWritten :: T.Text -> T.Text +stripPartiallyWritten = T.dropWhileEnd (\y -> (y /= ' ') && (y /= ':')) + +-- | Calculates how many spaces the currently completed item is indented. +completionIndentation :: CabalPrefixInfo -> Int +completionIndentation prefInfo = fromIntegral (pos ^. JL.character) - (T.length $ completionPrefix prefInfo) + where + pos = completionCursorPosition prefInfo diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} + +module Ide.Plugin.Cabal.Completion.Data where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE.GHC.Compat.Core (flagsForCompletion) +import Distribution.CabalSpecVersion (CabalSpecVersion (CabalSpecV2_2), + showCabalSpecVersion) +import Ide.Plugin.Cabal.Completion.Completer.FilePath +import Ide.Plugin.Cabal.Completion.Completer.Module +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Types +import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) + +-- ---------------------------------------------------------------- +-- Completion Data +-- ---------------------------------------------------------------- + +-- | Keyword for cabal version; required to be the top line in a cabal file +cabalVersionKeyword :: Map KeyWordName Completer +cabalVersionKeyword = + Map.singleton "cabal-version:" $ + constantCompleter $ + -- We only suggest cabal versions newer than 2.2 + -- since we don't recommend using older ones. + map (T.pack . showCabalSpecVersion) [CabalSpecV2_2 .. maxBound] + +-- | Top level keywords of a cabal file. +-- +-- TODO: we could add descriptions of field values and +-- then show them when inside the field's context +cabalKeywords :: Map KeyWordName Completer +cabalKeywords = + Map.fromList + [ ("name:", nameCompleter), + ("version:", noopCompleter), + ("build-type:", constantCompleter ["Simple", "Custom", "Configure", "Make"]), + ("license:", weightedConstantCompleter licenseNames weightedLicenseNames), + ("license-file:", filePathCompleter), + ("license-files:", filePathCompleter), + ("copyright:", noopCompleter), + ("author:", noopCompleter), + ("maintainer:", noopCompleter), -- email address, use git config? + ("stability:", noopCompleter), + ("homepage:", noopCompleter), + ("bug-reports:", noopCompleter), + ("package-url:", noopCompleter), + ("synopsis:", noopCompleter), + ("description:", noopCompleter), + ("category:", noopCompleter), + ("tested-with:", constantCompleter ["GHC"]), + ("data-files:", filePathCompleter), + ("data-dir:", directoryCompleter), + ("extra-source-files:", filePathCompleter), + ("extra-doc-files:", filePathCompleter), + ("extra-tmp-files:", filePathCompleter) + ] + +-- | Map, containing all stanzas in a cabal file as keys +-- and lists of their possible nested keywords as values. +stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) +stanzaKeywordMap = + Map.fromList + [ ("library", libraryFields <> libExecTestBenchCommons), + ("executable", executableFields <> libExecTestBenchCommons), + ("test-suite", testSuiteFields <> libExecTestBenchCommons), + ("benchmark", benchmarkFields <> libExecTestBenchCommons), + ("foreign-library", foreignLibraryFields <> libExecTestBenchCommons), + ("flag", flagFields), + ("source-repository", sourceRepositoryFields) + ] + +libraryFields :: Map KeyWordName Completer +libraryFields = + Map.fromList + [ ("exposed-modules:", modulesCompleter sourceDirsExtractionLibrary), + ("virtual-modules:", noopCompleter), + ("exposed:", constantCompleter ["True", "False"]), + ("visibility:", constantCompleter ["private", "public"]), + ("reexported-modules:", noopCompleter), + ("signatures:", noopCompleter), + ("other-modules:", modulesCompleter sourceDirsExtractionLibrary) + ] + +executableFields :: Map KeyWordName Completer +executableFields = + Map.fromList + [ ("main-is:", mainIsCompleter sourceDirsExtractionExecutable), + ("scope:", constantCompleter ["public", "private"]), + ("other-modules:", modulesCompleter sourceDirsExtractionExecutable) + ] + +testSuiteFields :: Map KeyWordName Completer +testSuiteFields = + Map.fromList + [ ("type:", constantCompleter ["exitcode-stdio-1.0", "detailed-0.9"]), + ("main-is:", mainIsCompleter sourceDirsExtractionTestSuite), + ("other-modules:", modulesCompleter sourceDirsExtractionTestSuite) + ] + +benchmarkFields :: Map KeyWordName Completer +benchmarkFields = + Map.fromList + [ ("type:", noopCompleter), + ("main-is:", mainIsCompleter sourceDirsExtractionBenchmark), + ("other-modules:", modulesCompleter sourceDirsExtractionBenchmark) + ] + +foreignLibraryFields :: Map KeyWordName Completer +foreignLibraryFields = + Map.fromList + [ ("type:", constantCompleter ["native-static", "native-shared"]), + ("options:", constantCompleter ["standalone"]), + ("mod-def-file:", filePathCompleter), + ("lib-version-info:", noopCompleter), + ("lib-version-linux:", noopCompleter) + ] + +sourceRepositoryFields :: Map KeyWordName Completer +sourceRepositoryFields = + Map.fromList + [ ( "type:", + constantCompleter + [ "darcs", + "git", + "svn", + "cvs", + "mercurial", + "hg", + "bazaar", + "bzr", + "arch", + "monotone" + ] + ), + ("location:", noopCompleter), + ("module:", noopCompleter), + ("branch:", noopCompleter), + ("tag:", noopCompleter), + ("subdir:", directoryCompleter) + ] + +flagFields :: Map KeyWordName Completer +flagFields = + Map.fromList + [ ("description:", noopCompleter), + ("default:", constantCompleter ["True", "False"]), + ("manual:", constantCompleter ["False", "True"]), + ("lib-def-file:", noopCompleter), + ("lib-version-info:", noopCompleter), + ("lib-version-linux:", noopCompleter) + ] + +libExecTestBenchCommons :: Map KeyWordName Completer +libExecTestBenchCommons = + Map.fromList + [ ("build-depends:", noopCompleter), + ("hs-source-dirs:", directoryCompleter), + ("default-extensions:", noopCompleter), + ("other-extensions:", noopCompleter), + ("default-language:", constantCompleter ["GHC2021", "Haskell2010", "Haskell98"]), + ("other-languages:", noopCompleter), + ("build-tool-depends:", noopCompleter), + ("buildable:", constantCompleter ["True", "False"]), + ("ghc-options:", constantCompleter ghcOptions), + ("ghc-prof-options:", constantCompleter ghcOptions), + ("ghc-shared-options:", constantCompleter ghcOptions), + ("ghcjs-options:", constantCompleter ghcOptions), + ("ghcjs-prof-options:", constantCompleter ghcOptions), + ("ghcjs-shared-options:", constantCompleter ghcOptions), + ("includes:", filePathCompleter), + ("install-includes:", filePathCompleter), + ("include-dirs:", directoryCompleter), + ("c-sources:", filePathCompleter), + ("cxx-sources:", filePathCompleter), + ("asm-sources:", filePathCompleter), + ("cmm-sources:", filePathCompleter), + ("js-sources:", filePathCompleter), + ("extra-libraries:", noopCompleter), + ("extra-ghci-libraries:", noopCompleter), + ("extra-bundled-libraries:", noopCompleter), + ("extra-lib-dirs:", directoryCompleter), + ("cc-options:", noopCompleter), + ("cpp-options:", noopCompleter), + ("cxx-options:", noopCompleter), + ("cmm-options:", noopCompleter), + ("asm-options:", noopCompleter), + ("ld-options:", noopCompleter), + ("pkgconfig-depends:", noopCompleter), + ("frameworks:", noopCompleter), + ("extra-framework-dirs:", directoryCompleter), + ("mixins:", noopCompleter) + ] + +-- | Contains a map of the most commonly used licenses, weighted by their popularity. +-- +-- The data was extracted by Kleidukos from the alternative hackage frontend flora.pm. +weightedLicenseNames :: Map T.Text Double +weightedLicenseNames = + fmap statisticsToWeight $ + Map.fromList + [ ("BSD-3-Clause", 9955), + ("MIT", 3336), + ("GPL-3.0-only", 679), + ("LicenseRef-OtherLicense", 521), + ("Apache-2.0", 514), + ("LicenseRef-GPL", 443), + ("LicenseRef-PublicDomain", 318), + ("MPL-2.0", 288), + ("BSD-2-Clause", 174), + ("GPL-2.0-only", 160), + ("LicenseRef-LGPL", 146), + ("LGPL-2.1-only", 112), + ("LGPL-3.0-only", 100), + ("AGPL-3.0-only", 96), + ("ISC", 89), + ("LicenseRef-Apache", 45), + ("GPL-3.0-or-later", 43), + ("BSD-2-Clause-Patent", 33), + ("GPL-2.0-or-later", 21), + ("CC0-1.0", 16), + ("AGPL-3.0-or-later", 15), + ("LGPL-2.1-or-later", 12), + ("(BSD-2-Clause OR Apache-2.0)", 10), + ("(Apache-2.0 OR MPL-2.0)", 8), + ("LicenseRef-AGPL", 6), + ("(BSD-3-Clause OR Apache-2.0)", 4), + ("0BSD", 3), + ("BSD-4-Clause", 3), + ("LGPL-3.0-or-later", 3), + ("LicenseRef-LGPL-2", 2), + ("GPL-2.0-or-later AND BSD-3-Clause", 2), + ("NONE", 2), + ("Zlib", 2), + ("(Apache-2.0 OR BSD-3-Clause)", 2), + ("BSD-3-Clause AND GPL-2.0-or-later", 2), + ("BSD-3-Clause AND GPL-3.0-or-later", 2) + ] + where + -- Add weights to each usage value from above, the weights are chosen + -- arbitrarily in order for completions to prioritize which licenses to + -- suggest in a sensible way + statisticsToWeight :: Int -> Double + statisticsToWeight stat + | stat < 10 = 0.1 + | stat < 20 = 0.3 + | stat < 50 = 0.4 + | stat < 100 = 0.5 + | stat < 500 = 0.6 + | stat < 650 = 0.7 + | otherwise = 0.9 + +ghcOptions :: [T.Text] +ghcOptions = map T.pack $ flagsForCompletion False diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Completion.Types where + +import Control.DeepSeq (NFData) +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE as D +import GHC.Generics +import qualified Ide.Plugin.Cabal.Parse as Parse + +data Log + = LogFileSplitError Position + | -- | This should never occur since we extract the word to lookup from the same map we look it up in. + LogUnknownKeyWordInContextError KeyWordName + | -- | This should never occur since we extract the word to lookup from the same map we look it up in. + LogUnknownStanzaNameInContextError StanzaName + | LogFilePathCompleterIOError FilePath IOError + | LogUseWithStaleFastNoResult + | LogMapLookUpOfKnownKeyFailed T.Text + deriving (Show) + +instance Pretty Log where + pretty = \case + LogFileSplitError pos -> "An error occurred when trying to separate the lines of the cabal file at position:" <+> pretty pos + LogUnknownKeyWordInContextError kw -> + "Lookup of key word failed for:" <+> viaShow kw + LogUnknownStanzaNameInContextError sn -> + "Lookup of stanza name failed for:" <+> viaShow sn + LogFilePathCompleterIOError fp ioErr -> + "When trying to complete the file path:" <+> pretty fp <+> "the following unexpected IO error occurred" <+> viaShow ioErr + LogUseWithStaleFastNoResult -> "Package description couldn't be read" + LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key + +type instance RuleResult GetCabalDiagnostics = Parse.GenericPackageDescription + +data GetCabalDiagnostics = GetCabalDiagnostics + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetCabalDiagnostics + +instance NFData GetCabalDiagnostics + +-- | The context a cursor can be in within a cabal file. +-- +-- We can be in stanzas or the top level, +-- and additionally we can be in a context where we have already +-- written a keyword but no value for it yet +type Context = (StanzaContext, FieldContext) + +-- | Context inside a cabal file. +-- Used to decide which keywords to suggest. +data StanzaContext + = -- | Top level context in a cabal file such as 'author' + TopLevel + | -- | Nested context in a cabal file, such as 'library'. + -- + -- Stanzas have their own fields which differ from top-level fields. + -- Each stanza must be named, such as 'executable exe', + -- except for the main library. + Stanza StanzaType (Maybe StanzaName) + deriving (Eq, Show, Read) + +-- | Keyword context in a cabal file. +-- +-- Used to decide whether to suggest values or keywords. +data FieldContext + = -- | Key word context, where a keyword + -- occurs right before the current word + -- to be completed + KeyWord KeyWordName + | -- | Keyword context where no keyword occurs + -- right before the current word to be completed + None + deriving (Eq, Show, Read) + +type KeyWordName = T.Text + +type StanzaName = T.Text + +type StanzaType = T.Text + +-- | Information regarding the current completion status +-- +-- Example: @"dir1/fi@ having been written to the file +-- would correspond to: +-- +-- @ +-- completionPrefix = "dir1/fi" +-- isStringNotation = LeftSide +-- ... +-- @ +-- +-- We define this type instead of simply using +-- VFS.PosPrefixInfo since e.g. for filepaths we +-- need more than just the word before the +-- cursor (as can be seen above), +-- since we want to capture the whole filepath +-- before the cursor. +-- +-- We also use this type to wrap all information +-- necessary to complete filepaths and other values +-- in a cabal file. +data CabalPrefixInfo = CabalPrefixInfo + { -- | text prefix to complete + completionPrefix :: T.Text, + -- | Did the completion happen in the context of a string notation, + -- i.e. are there apostrophes around the item to be completed + isStringNotation :: Maybe Apostrophe, + -- | the current position of the cursor in the file + completionCursorPosition :: Position, + -- | range where completion is to be inserted + completionRange :: Range, + -- | directory of the handled cabal file + completionWorkingDir :: FilePath, + -- | filename of the handled cabal file + completionFileName :: T.Text + } + deriving (Eq, Show) + +-- | Where are the apostrophes around the item to be completed? +-- +-- 'Surrounded' means the item to complete already has the necessary apostrophes, +-- while 'LeftSide' means, a closing apostrophe has to be added after the completion item. +data Apostrophe = Surrounded | LeftSide + deriving (Eq, Ord, Show) + +-- | Wraps a completion in apostrophes where appropriate. +-- +-- If a completion starts with an apostrophe we want to end it with an apostrophe. +-- If a completed filepath contains a space, it can only be written in the cabal +-- file if it is wrapped in apostrophes, thus we wrap it. +applyStringNotation :: Maybe Apostrophe -> T.Text -> T.Text +applyStringNotation (Just Surrounded) compl = compl +applyStringNotation (Just LeftSide) compl = compl <> "\"" +applyStringNotation Nothing compl + | Just _ <- T.find (== ' ') compl = "\"" <> compl <> "\"" + | otherwise = compl diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Cabal.Diagnostics +( errorDiagnostic +, warningDiagnostic +, positionFromCabalPosition + -- * Re-exports +, FileDiagnostic +, Diagnostic(..) +) +where + +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + ShowDiagnostic (ShowDiag)) +import Distribution.Fields (showPError, showPWarning) +import qualified Ide.Plugin.Cabal.Parse as Lib +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + Position (Position), + Range (Range), + fromNormalizedFilePath) + +-- | Produce a diagnostic from a Cabal parser error +errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic +errorDiagnostic fp err@(Lib.PError pos _) = + mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg + where + msg = T.pack $ showPError (fromNormalizedFilePath fp) err + +-- | Produce a diagnostic from a Cabal parser warning +warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic +warningDiagnostic fp warning@(Lib.PWarning _ pos _) = + mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg + where + msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning + +-- | The Cabal parser does not output a _range_ for a warning/error, +-- only a single source code 'Lib.Position'. +-- We define the range to be _from_ this position +-- _to_ the first column of the next line. +toBeginningOfNextLine :: Lib.Position -> Range +toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos + where + pos = positionFromCabalPosition cabalPos + +-- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands. +-- +-- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based, +-- while Cabal is one-based. +-- +-- >>> positionFromCabalPosition $ Lib.Position 1 1 +-- Position 0 0 +positionFromCabalPosition :: Lib.Position -> Position +positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col') + where + -- LSP is zero-based, Cabal is one-based + line' = line-1 + col' = column-1 + +-- | Create a 'FileDiagnostic' +mkDiag + :: NormalizedFilePath + -- ^ Cabal file path + -> T.Text + -- ^ Where does the diagnostic come from? + -> DiagnosticSeverity + -- ^ Severity + -> Range + -- ^ Which source code range should the editor highlight? + -> T.Text + -- ^ The message displayed by the editor + -> FileDiagnostic +mkDiag file diagSource sev loc msg = (file, ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _tags = Nothing + , _relatedInformation = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Cabal.LicenseSuggest +( licenseErrorSuggestion +, licenseErrorAction +, licenseNames + -- * Re-exports +, T.Text +, Diagnostic(..) +) +where + +import qualified Data.Map as Map +import qualified Data.Text as T +import Language.LSP.Protocol.Types (CodeAction (CodeAction), + CodeActionKind (CodeActionKind_QuickFix), + Diagnostic (..), + Position (Position), + Range (Range), + TextEdit (TextEdit), Uri, + WorkspaceEdit (WorkspaceEdit)) +import Text.Regex.TDFA + +import qualified Data.List as List +import Distribution.SPDX.LicenseId (licenseId) +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- if it represents an "Unknown SPDX license identifier"-error along +-- with a suggestion, then return a 'CodeAction' for replacing the +-- the incorrect license identifier with the suggestion. +licenseErrorAction + :: Uri + -- ^ File for which the diagnostic was generated + -> Diagnostic + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -> [CodeAction] +licenseErrorAction uri diag = + mkCodeAction <$> licenseErrorSuggestion (_message diag) + where + mkCodeAction (original, suggestion) = + let + -- The Cabal parser does not output the _range_ of the incorrect license identifier, + -- only a single source code position. Consequently, in 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -- we define the range to be from the returned position the first column of the next line. + -- Since the "replace" code action replaces this range, we need to modify the range to + -- start at the first character of the invalid license identifier. We achieve this by + -- subtracting the length of the identifier from the beginning of the range. + adjustRange (Range (Position line col) rangeTo) = + Range (Position line (col - fromIntegral (T.length original))) rangeTo + title = "Replace with " <> suggestion + -- We must also add a newline character to the replacement since the range returned by + -- 'Ide.Plugin.Cabal.Diag.errorDiagnostic' ends at the beginning of the following line. + tedit = [TextEdit (adjustRange $ _range diag) (suggestion <> "\n")] + edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing + +-- | License name of every license supported by cabal +licenseNames :: [T.Text] +licenseNames = map (T.pack . licenseId) [minBound .. maxBound] + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- provide possible corrections for SPDX license identifiers +-- based on the list specified in Cabal. +-- Results are sorted by best fit, and prefer solutions that have smaller +-- length distance to the original word. +-- +-- >>> take 2 $ licenseErrorSuggestion (T.pack "Unknown SPDX license identifier: 'BSD3'") +-- [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")] +licenseErrorSuggestion :: + T.Text + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -> [(T.Text, T.Text)] + -- ^ (Original (incorrect) license identifier, suggested replacement) +licenseErrorSuggestion msg = + (getMatch <$> msg =~~ regex) >>= \case + [original] -> + let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults original licenseNames + in [(original,candidate) | candidate <- List.sortBy (lengthDistance original) matches] + _ -> [] + where + regex :: T.Text + regex = "Unknown SPDX license identifier: '(.*)'" + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] + getMatch (_, _, _, results) = results + lengthDistance original x1 x2 = abs (T.length original - T.length x1) `compare` abs (T.length original - T.length x2) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -0,0 +1,27 @@ +module Ide.Plugin.Cabal.Parse +( parseCabalFileContents + -- * Re-exports +, FilePath +, NonEmpty(..) +, PWarning(..) +, Version +, PError(..) +, Position(..) +, GenericPackageDescription(..) +) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Distribution.Fields (PError (..), + PWarning (..)) +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Parsec.Position (Position (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) +import Distribution.Types.Version (Version) + +parseCabalFileContents + :: BS.ByteString -- ^ UTF-8 encoded bytestring + -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) +parseCabalFileContents bs = + pure $ runParseResult (parseGenericPackageDescription bs) diff --git a/plugins/hls-cabal-plugin/test/Completer.hs b/plugins/hls-cabal-plugin/test/Completer.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Completer.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Completer where + +import Control.Lens ((^.), (^?)) +import Control.Lens.Prism +import qualified Data.ByteString as ByteString +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Ide.Plugin.Cabal.Completion.Completer.FilePath +import Ide.Plugin.Cabal.Completion.Completer.Module +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Types (CompleterData (..)) +import Ide.Plugin.Cabal.Completion.Completions +import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), + StanzaName) +import Ide.Plugin.Cabal.Parse (GenericPackageDescription) +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls +import Utils + +completerTests :: TestTree +completerTests = + testGroup + "Completer Tests" + [ basicCompleterTests, + fileCompleterTests, + filePathCompletionContextTests, + directoryCompleterTests, + completionHelperTests, + filePathExposedModulesTests, + exposedModuleCompleterTests + ] + +basicCompleterTests :: TestTree +basicCompleterTests = + testGroup + "Basic Completer Tests" + [ runCabalTestCaseSession "In stanza context - stanza should not be suggested" "" $ do + doc <- openDoc "completer.cabal" "cabal" + compls <- getCompletions doc (Position 11 7) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "does not suggest library" $ "library" `notElem` complTexts + liftIO $ assertBool "suggests library keyword" $ "extra-libraries:" `elem` complTexts + , runCabalTestCaseSession "In top level context - stanza should be suggested" "" $ do + doc <- openDoc "completer.cabal" "cabal" + compls <- getCompletions doc (Position 8 2) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "suggests benchmark" $ "benchmark" `elem` complTexts + , runCabalTestCaseSession "Main-is completions should be relative to hs-source-dirs of same stanza" "filepath-completions" $ do + doc <- openDoc "main-is.cabal" "cabal" + compls <- getCompletions doc (Position 10 12) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "suggests f2" $ "./f2.hs" `elem` complTexts + liftIO $ assertBool "does not suggest" $ "./Content.hs" `notElem` complTexts + ] + where + getTextEditTexts :: [CompletionItem] -> [T.Text] + getTextEditTexts compls = mapMaybe (^? L.textEdit . _Just . _L . L.newText) compls + +fileCompleterTests :: TestTree +fileCompleterTests = + testGroup + "File Completer Tests" + [ testCase "Current Directory" $ do + completions <- completeFilePath "" filePathComplTestDir + completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"], + testCase "Current Directory - alternative writing" $ do + completions <- completeFilePath "./" filePathComplTestDir + completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"], + testCase "Current Directory - hidden file start" $ do + completions <- completeFilePath "." filePathComplTestDir + completions @?== ["./Content.hs", "./.hidden", "./textfile.txt", "./main-is.cabal"], + testCase "Current Directory - incomplete directory path written" $ do + completions <- completeFilePath "di" filePathComplTestDir + completions @?== ["./dir1/", "./dir2/"], + testCase "Current Directory - incomplete filepath written" $ do + completions <- completeFilePath "te" filePathComplTestDir + completions @?== ["./Content.hs", "./textfile.txt"], + testCase "Subdirectory" $ do + completions <- completeFilePath "dir1/" filePathComplTestDir + completions @?== ["dir1/f1.txt", "dir1/f2.hs"], + testCase "Subdirectory - incomplete filepath written" $ do + completions <- completeFilePath "dir2/dir3/MA" filePathComplTestDir + completions @?== ["dir2/dir3/MARKDOWN.md"], + testCase "Nonexistent directory" $ do + completions <- completeFilePath "dir2/dir4/" filePathComplTestDir + completions @?== [] + ] + where + completeFilePath :: T.Text -> TestName -> IO [T.Text] + completeFilePath written dirName = do + completer <- filePathCompleter mempty $ mkCompleterData $ simpleCabalPrefixInfoFromFp written dirName + pure $ fmap extract completer + +filePathCompletionContextTests :: TestTree +filePathCompletionContextTests = + testGroup + "File Path Completion Context Tests" + [ testCase "empty file - start" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "" 0 0) + completionPrefix complContext @?= "", + testCase "only whitespaces" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " " 0 3) + completionPrefix complContext @?= "", + testCase "simple filepath" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " src/" 0 7) + completionPrefix complContext @?= "src/", + testCase "simple filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " \"src/" 0 8) + completionPrefix complContext @?= "src/", + testCase "simple filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " \"src/\"" 0 8) + completionPrefix complContext @?= "src/", + testCase "second filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/" 0 12) + completionPrefix complContext @?= "src/", + testCase "middle filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/ fp2.txt" 0 12) + completionPrefix complContext @?= "src/", + testCase "middle filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.t xt \"src\" fp2.txt" 0 12) + completionPrefix complContext @?= "src", + testCase "middle filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "\"fp.txt\" \"src fp2.txt" 0 13) + completionPrefix complContext @?= "src", + testCase "Current Directory" $ do + compls <- + listFileCompletions + mempty + PathCompletionInfo + { isStringNotationPath = Nothing, + pathSegment = "", + queryDirectory = "", + workingDirectory = filePathComplTestDir + } + compls @?== [".hidden", "Content.hs", "dir1/", "dir2/", "textfile.txt", "main-is.cabal"], + testCase "In directory" $ do + compls <- + listFileCompletions + mempty + PathCompletionInfo + { isStringNotationPath = Nothing, + pathSegment = "", + queryDirectory = "dir1/", + workingDirectory = filePathComplTestDir + } + compls @?== ["f1.txt", "f2.hs"] + ] + where + simplePosPrefixInfo :: T.Text -> UInt -> UInt -> Ghcide.PosPrefixInfo + simplePosPrefixInfo lineString linePos charPos = + Ghcide.PosPrefixInfo + { Ghcide.fullLine = lineString, + Ghcide.prefixScope = "", + Ghcide.prefixText = "", + Ghcide.cursorPos = Position linePos charPos + } + +directoryCompleterTests :: TestTree +directoryCompleterTests = + testGroup + "Directory Completer Tests" + [ testCase "Current Directory" $ do + completions <- completeDirectory "" filePathComplTestDir + completions @?== ["./dir1/", "./dir2/"], + testCase "Current Directory - alternative writing" $ do + completions <- completeDirectory "./" filePathComplTestDir + completions @?== ["./dir1/", "./dir2/"], + testCase "Current Directory - incomplete directory path written" $ do + completions <- completeDirectory "di" filePathComplTestDir + completions @?== ["./dir1/", "./dir2/"], + testCase "Current Directory - incomplete filepath written" $ do + completions <- completeDirectory "te" filePathComplTestDir + completions @?== [], + testCase "Subdirectory - no more directories found" $ do + completions <- completeDirectory "dir1/" filePathComplTestDir + completions @?== [], + testCase "Subdirectory - available subdirectory" $ do + completions <- completeDirectory "dir2/" filePathComplTestDir + completions @?== ["dir2/dir3/"], + testCase "Nonexistent directory" $ do + completions <- completeDirectory "dir2/dir4/" filePathComplTestDir + completions @?== [] + ] + where + completeDirectory :: T.Text -> TestName -> IO [T.Text] + completeDirectory written dirName = do + completer <- directoryCompleter mempty $ mkCompleterData $ simpleCabalPrefixInfoFromFp written dirName + pure $ fmap extract completer + +completionHelperTests :: TestTree +completionHelperTests = + testGroup + "Completion Helper Tests" + [ testCase "get FilePath - partly written file path" $ do + getFilePathCursorPrefix "src/a" 0 5 @?= "src/a", + testCase "get FilePath - ignores spaces" $ do + getFilePathCursorPrefix " src/a" 0 7 @?= "src/a", + testCase "get FilePath - ignores spaces and keyword" $ do + getFilePathCursorPrefix "license-file: src/a" 0 19 @?= "src/a", + testCase "get FilePath - with apostrophe, ignores spaces and keyword" $ do + getFilePathCursorPrefix "license-file: \"src/a" 0 20 @?= "src/a", + testCase "get FilePath - ignores list of filepaths beforehand, space separated" $ do + getFilePathCursorPrefix " ./text.txt file.h" 0 19 @?= "file.h", + testCase "get FilePath - ignores list of filepaths after, space separated" $ do + getFilePathCursorPrefix " ./text.t file.h" 0 10 @?= "./text.t", + testCase "get FilePath - ignores list of filepaths and rest of filepath after, space separated" $ do + getFilePathCursorPrefix " ./text.t file.h" 0 6 @?= "./te", + testCase "get FilePath - ignores list of filepaths beforehand, multiple space separated" $ do + getFilePathCursorPrefix " ./text.txt file.h" 0 21 @?= "file.h", + testCase "get FilePath - ignores list of filepaths beforehand, comma separated" $ do + getFilePathCursorPrefix " ./text.txt, file.h" 0 20 @?= "file.h", + testCase "get FilePath - ignores list of filepaths beforehand, comma separated, many whitespaces" $ do + getFilePathCursorPrefix " ./text.txt, file.h" 0 22 @?= "file.h", + testCase "get FilePath - ignores list of filepaths beforehand, comma separated, no whitespace" $ do + getFilePathCursorPrefix " ./text.txt,file.h" 0 19 @?= "file.h", + testCase "get FilePath - with apostrophes, ignores list of filepaths beforehand" $ do + getFilePathCursorPrefix " \"./text.txt\" \"file.h" 0 23 @?= "file.h", + testCase "get FilePath - ignores list of filepaths with apostrophe beforehand" $ do + getFilePathCursorPrefix " \"./text.txt\" file.h" 0 22 @?= "file.h" + ] + where + getFilePathCursorPrefix :: T.Text -> UInt -> UInt -> T.Text + getFilePathCursorPrefix lineString linePos charPos = + completionPrefix . getCabalPrefixInfo "" $ + Ghcide.PosPrefixInfo + { Ghcide.fullLine = lineString, + Ghcide.prefixScope = "", + Ghcide.prefixText = "", + Ghcide.cursorPos = Position linePos charPos + } + +filePathExposedModulesTests :: TestTree +filePathExposedModulesTests = + testGroup + "Filepaths for Exposed Modules Tests" + [ testCase "Root dir" $ do + exposed <- callFilePathsForExposedModules ["./"] + exposed @?== ["Dir1.", "File1"], + testCase "Nested path" $ do + exposed <- callFilePathsForExposedModules ["./Dir1/Dir2/"] + exposed @?== ["File2"], + testCase "Nested empty dir" $ do + exposed <- callFilePathsForExposedModules ["./Dir1/Dir2/Dir4"] + exposed @?== [], + testCase "Two dirs" $ do + exposed <- callFilePathsForExposedModules ["./Dir1/", "Dir1/Dir3/Dir4/"] + exposed @?== ["Dir2.", "Dir3.", "File3"] + ] + where + callFilePathsForExposedModules :: [FilePath] -> IO [T.Text] + callFilePathsForExposedModules srcDirs = do + let prefInfo = simpleCabalPrefixInfoFromFp "" exposedTestDir + filePathsForExposedModules mempty srcDirs prefInfo + +exposedModuleCompleterTests :: TestTree +exposedModuleCompleterTests = + testGroup + "Exposed Modules Completer Tests" + [ testCase "Top level single source dir, library" $ do + completions <- callModulesCompleter Nothing sourceDirsExtractionLibrary "" + completions @?== ["Dir2.", "Dir3."], + testCase "Top level single source dir, benchmark, with prefix" $ do + completions <- callModulesCompleter (Just "benchie") sourceDirsExtractionBenchmark "Fi" + completions @?== ["File1"], + testCase "Top level single source dir, named executable" $ do + completions <- callModulesCompleter (Just "executie") sourceDirsExtractionExecutable "" + completions @?== ["File1", "Dir1.", "Dir2.", "Dir3."], + testCase "Top level single source dir, named executable" $ do + completions <- callModulesCompleter (Just "exe-not-so-cutie") sourceDirsExtractionExecutable "" + completions @?== ["File2", "Dir4."], + testCase "Top level single source dir, nonexistent name" $ do + completions <- callModulesCompleter (Just "exe-the-beste") sourceDirsExtractionExecutable "" + completions @?== [], + testCase "Top level single source dir, testsuite, with prefix" $ do + completions <- callModulesCompleter (Just "suitor") sourceDirsExtractionTestSuite "3" + completions @?== ["File3"], + testCase "Name nothing but not library" $ do + completions <- callModulesCompleter Nothing sourceDirsExtractionTestSuite "3" + completions @?== [] + ] + where + simpleCompleterData :: Maybe StanzaName -> FilePath -> T.Text -> CompleterData + simpleCompleterData sName dir pref = do + CompleterData + { cabalPrefixInfo = simpleExposedCabalPrefixInfo pref dir, + getLatestGPD = do + cabalContents <- ByteString.readFile $ testDataDir "exposed.cabal" + pure $ parseGenericPackageDescriptionMaybe cabalContents, + stanzaName = sName + } + callModulesCompleter :: Maybe StanzaName -> (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> T.Text -> IO [T.Text] + callModulesCompleter sName func prefix = do + let cData = simpleCompleterData sName testDataDir prefix + completer <- modulesCompleter func mempty cData + pure $ fmap extract completer + +mkCompleterData :: CabalPrefixInfo -> CompleterData +mkCompleterData prefInfo = CompleterData {getLatestGPD = undefined, cabalPrefixInfo = prefInfo, stanzaName = Nothing} + +exposedTestDir :: FilePath +exposedTestDir = addTrailingPathSeparator $ testDataDir "src-modules" + +simpleExposedCabalPrefixInfo :: T.Text -> FilePath -> CabalPrefixInfo +simpleExposedCabalPrefixInfo prefix fp = + CabalPrefixInfo + { completionPrefix = prefix, + isStringNotation = Nothing, + completionCursorPosition = Position 0 0, + completionRange = Range (Position 0 0) (Position 0 0), + completionWorkingDir = fp, + completionFileName = "exposed.cabal" + } + +extract :: CompletionItem -> T.Text +extract item = case item ^. L.textEdit of + Just (InL v) -> v ^. L.newText + _ -> error "" diff --git a/plugins/hls-cabal-plugin/test/Context.hs b/plugins/hls-cabal-plugin/test/Context.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Context.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Context where + +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Ide.Plugin.Cabal +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completions +import Ide.Plugin.Cabal.Completion.Types (Context, + FieldContext (KeyWord, None), + StanzaContext (Stanza, TopLevel)) +import Test.Hls +import Utils as T + +cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log +cabalPlugin = mkPluginTestDescriptor descriptor "cabal context" + +contextTests :: TestTree +contextTests = + testGroup + "Context Tests " + [ pathCompletionInfoFromCompletionContextTests + , getContextTests + ] + +pathCompletionInfoFromCompletionContextTests :: TestTree +pathCompletionInfoFromCompletionContextTests = + testGroup + "Completion Info to Completion Context Tests" + [ testCase "Current Directory" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "" testDataDir + queryDirectory complInfo @?= "./" + , testCase "Current Directory - partly written next" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "di" testDataDir + queryDirectory complInfo @?= "./" + pathSegment complInfo @?= "di" + , testCase "Current Directory - alternative writing" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "./" testDataDir + queryDirectory complInfo @?= "./" + , testCase "Subdirectory" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/" testDataDir + queryDirectory complInfo @?= "dir1/" + pathSegment complInfo @?= "" + , testCase "Subdirectory - partly written next" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/d" testDataDir + queryDirectory complInfo @?= "dir1/" + pathSegment complInfo @?= "d" + , testCase "Subdirectory - partly written next" $ do + let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "dir1/dir2/d" testDataDir + queryDirectory complInfo @?= "dir1/dir2/" + pathSegment complInfo @?= "d" + ] + +getContextTests :: TestTree +getContextTests = + testGroup + "Context Tests" + [ testCase "Empty File - Start" $ do + -- for a completely empty file, the context needs to + -- be top level without a specified keyword + ctx <- callGetContext (Position 0 0) "" [""] + ctx @?= (TopLevel, None) + , testCase "Cabal version keyword - no value, no space after :" $ do + -- on a file, where the keyword is already written + -- the context should still be toplevel but the keyword should be recognized + ctx <- callGetContext (Position 0 14) "" ["cabal-version:"] + ctx @?= (TopLevel, KeyWord "cabal-version:") + , testCase "Cabal version keyword - cursor in keyword" $ do + -- on a file, where the keyword is already written + -- but the cursor is in the middle of the keyword, + -- we are not in a keyword context + ctx <- callGetContext (Position 0 5) "cabal" ["cabal-version:"] + ctx @?= (TopLevel, None) + , testCase "Cabal version keyword - no value, many spaces" $ do + -- on a file, where the "cabal-version:" keyword is already written + -- the context should still be top level but the keyword should be recognized + ctx <- callGetContext (Position 0 45) "" ["cabal-version:" <> T.replicate 50 " "] + ctx @?= (TopLevel, KeyWord "cabal-version:") + , testCase "Cabal version keyword - keyword partly written" $ do + -- in the first line of the file, if the keyword + -- has not been written completely, the keyword context + -- should still be None + ctx <- callGetContext (Position 0 5) "cabal" ["cabal"] + ctx @?= (TopLevel, None) + , testCase "Cabal version keyword - value partly written" $ do + -- in the first line of the file, if the keyword + -- has not been written completely, the keyword context + -- should still be None + ctx <- callGetContext (Position 0 17) "1." ["cabal-version: 1."] + ctx @?= (TopLevel, KeyWord "cabal-version:") + , testCase "Inside Stanza - no keyword" $ do + -- on a file, where the library stanza has been defined + -- but no keyword is defined afterwards, the stanza context should be recognized + ctx <- callGetContext (Position 3 2) "" libraryStanzaData + ctx @?= (Stanza "library" Nothing, None) + , testCase "Inside Stanza - keyword, no value" $ do + -- on a file, where the library stanza and a keyword + -- has been defined, the keyword and stanza should be recognized + ctx <- callGetContext (Position 4 21) "" libraryStanzaData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , expectFailBecause "While not valid, it is not that important to make the code more complicated for this" $ + testCase "Cabal version keyword - no value, next line" $ do + -- if the cabal version keyword has been written but without a value, + -- in the next line we still should be in top level context with no keyword + -- since the cabal version keyword and value pair need to be in the same line + ctx <- callGetContext (Position 1 2) "" ["cabal-version:", ""] + ctx @?= (TopLevel, None) + , testCase "Non-cabal-version keyword - no value, next line indentented position" $ do + -- if a keyword, other than the cabal version keyword has been written + -- with no value, in the next line we still should be in top level keyword context + -- of the keyword with no value, since its value may be written in the next line + ctx <- callGetContext (Position 2 4) "" topLevelData + ctx @?= (TopLevel, KeyWord "name:") + , testCase "Non-cabal-version keyword - no value, next line at start" $ do + -- if a keyword, other than the cabal version keyword has been written + -- with no value, in the next line we still should be in top level context + -- but not the keyword's, since it is not viable to write a value for a + -- keyword a the start of the next line + ctx <- callGetContext (Position 2 0) "" topLevelData + ctx @?= (TopLevel, None) + , testCase "Toplevel after stanza partially written" $ do + ctx <- callGetContext (Position 6 2) "ma" libraryStanzaData + ctx @?= (TopLevel, None) + , testCase "Non-cabal-version keyword - no value, multiple lines between" $ do + -- if a keyword, other than the cabal version keyword has been written + -- with no value, even with multiple lines in between we can still write the + -- value corresponding to the keyword + ctx <- callGetContext (Position 5 4) "" topLevelData + ctx @?= (TopLevel, KeyWord "name:") + , testCase "Keyword inside stanza - cursor indented more than keyword in next line" $ do + -- if a keyword, other than the cabal version keyword has been written + -- in a stanza context with no value, then the value may be written in the next line, + -- when the cursor is indented more than the keyword + ctx <- callGetContext (Position 5 8) "" libraryStanzaData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , testCase "Keyword inside stanza - cursor indented less than keyword in next line" $ do + -- if a keyword, other than the cabal version keyword has been written + -- in a stanza context with no value, then the value may not be written in the next line, + -- when the cursor is indented less than the keyword + ctx <- callGetContext (Position 5 2) "" libraryStanzaData + ctx @?= (Stanza "library" Nothing, None) + , testCase "Keyword inside stanza - cursor at start of next line" $ do + -- in a stanza context with no value the value may not be written in the next line, + -- when the cursor is not indented and we are in the top level context + ctx <- callGetContext (Position 5 0) "" libraryStanzaData + ctx @?= (TopLevel, None) + , testCase "Top level - cursor in later line with partially written value" $ do + ctx <- callGetContext (Position 5 13) "eee" topLevelData + ctx @?= (TopLevel, KeyWord "name:") + , testCase "Named Stanza" $ do + ctx <- callGetContext (Position 2 18) "" executableStanzaData + ctx @?= (Stanza "executable" (Just "exeName"), None) + ] + where + callGetContext :: Position -> T.Text -> [T.Text] -> IO Context + callGetContext pos pref ls = do + runMaybeT (getContext mempty (simpleCabalPrefixInfoFromPos pos pref) (Rope.fromText $ T.unlines ls)) + >>= \case + Nothing -> assertFailure "Context must be found" + Just ctx -> pure ctx + +-- ------------------------------------------------------------------------ +-- Test Data +-- ------------------------------------------------------------------------ + +libraryStanzaData :: [T.Text] +libraryStanzaData = + [ "cabal-version: 3.0" + , "name: simple-cabal" + , "library " + , " default-language: Haskell98" + , " build-depends: " + , " " + , "ma " + ] + +executableStanzaData :: [T.Text] +executableStanzaData = + [ "cabal-version: 3.0" + , "name: simple-cabal" + , "executable exeName" + , " default-language: Haskell2010" + , " hs-source-dirs: test/preprocessor" + ] + +topLevelData :: [T.Text] +topLevelData = + [ "cabal-version: 3.0" + , "name:" + , "" + , "" + , "" + , " eee" + ] diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( + main, +) where + +import Completer (completerTests) +import Context (contextTests) +import Control.Lens ((^.)) +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.Either (isRight) +import Data.Row +import qualified Data.Text as T +import qualified Data.Text as Text +import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) +import qualified Ide.Plugin.Cabal.Parse as Lib +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls +import Utils + +main :: IO () +main = do + defaultTestRunner $ + testGroup + "Cabal Plugin Tests" + [ unitTests + , pluginTests + , completerTests + , contextTests + ] + +-- ------------------------------------------------------------------------ +-- Unit Tests +-- ------------------------------------------------------------------------ + +unitTests :: TestTree +unitTests = + testGroup + "Unit Tests" + [ cabalParserUnitTests + , codeActionUnitTests + ] + +cabalParserUnitTests :: TestTree +cabalParserUnitTests = + testGroup + "Parsing Cabal" + [ testCase "Simple Parsing works" $ do + (warnings, pm) <- Lib.parseCabalFileContents =<< BS.readFile (testDataDir "simple.cabal") + liftIO $ do + null warnings @? "Found unexpected warnings" + isRight pm @? "Failed to parse GenericPackageDescription" + ] + +codeActionUnitTests :: TestTree +codeActionUnitTests = + testGroup + "Code Action Tests" + [ testCase "Unknown format" $ do + -- the message has the wrong format + licenseErrorSuggestion "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= [] + , testCase "BSD-3-Clause" $ do + take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?") + @?= [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")] + , testCase "MiT" $ do + -- contains no suggestion + take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'MiT'") + @?= [("MiT", "MIT"), ("MiT", "MIT-0")] + ] + +-- ------------------------ ------------------------------------------------ +-- Integration Tests +-- ------------------------------------------------------------------------ + +pluginTests :: TestTree +pluginTests = + testGroup + "Plugin Tests" + [ testGroup + "Diagnostics" + [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do + doc <- openDoc "invalid.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error + , runCabalTestCaseSession "Clears diagnostics" "" $ do + doc <- openDoc "invalid.cabal" "cabal" + diags <- waitForDiagnosticsFrom doc + unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error + _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" + newDiags <- waitForDiagnosticsFrom doc + liftIO $ newDiags @?= [] + , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do + hsDoc <- openDoc "A.hs" "haskell" + expectNoMoreDiagnostics 1 hsDoc "typechecking" + cabalDoc <- openDoc "simple-cabal.cabal" "cabal" + expectNoMoreDiagnostics 1 cabalDoc "parsing" + , ignoreTestBecause "Testcase is flaky for certain GHC versions (e.g. 9.2.5). See #3333 for details." $ do + runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "simple-cabal" $ do + hsDoc <- openDoc "A.hs" "haskell" + expectNoMoreDiagnostics 1 hsDoc "typechecking" + cabalDoc <- openDoc "simple-cabal.cabal" "cabal" + expectNoMoreDiagnostics 1 cabalDoc "parsing" + let theRange = Range (Position 3 20) (Position 3 23) + -- Invalid license + changeDoc + cabalDoc + [ TextDocumentContentChangeEvent $ + InL $ + #range + .== theRange + .+ #rangeLength + .== Nothing + .+ #text + .== "MIT3" + ] + cabalDiags <- waitForDiagnosticsFrom cabalDoc + unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"] + expectNoMoreDiagnostics 1 hsDoc "typechecking" + liftIO $ do + length cabalDiags @?= 1 + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error + ] + , testGroup + "Code Actions" + [ runCabalTestCaseSession "BSD-3" "" $ do + doc <- openDoc "licenseCodeAction.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction" + , "version: 0.1.0.0" + , "license: BSD-3-Clause" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + , runCabalTestCaseSession "Apache-2.0" "" $ do + doc <- openDoc "licenseCodeAction2.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + -- test if it supports typos in license name, here 'apahe' + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction2" + , "version: 0.1.0.0" + , "license: Apache-2.0" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + ] + ] + where + getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction] + getLicenseAction license codeActions = do + InR action@CodeAction{_title} <- codeActions + guard (_title == "Replace with " <> license) + pure action diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Utils where + +import Data.List (sort) +import qualified Data.Text as T +import Ide.Plugin.Cabal (descriptor) +import qualified Ide.Plugin.Cabal +import Ide.Plugin.Cabal.Completion.Types +import System.FilePath +import Test.Hls + +cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log +cabalPlugin = mkPluginTestDescriptor descriptor "cabal" + +simpleCabalPrefixInfoFromPos :: Position -> T.Text -> CabalPrefixInfo +simpleCabalPrefixInfoFromPos pos prefix = + CabalPrefixInfo + { completionPrefix = prefix + , completionCursorPosition = pos + , isStringNotation = Nothing + , completionRange = Range pos (Position 0 0) + , completionWorkingDir = "" + , completionFileName = "test" + } + +simpleCabalPrefixInfoFromFp :: T.Text -> FilePath -> CabalPrefixInfo +simpleCabalPrefixInfoFromFp prefix fp = + CabalPrefixInfo + { completionPrefix = prefix + , isStringNotation = Nothing + , completionCursorPosition = Position 0 0 + , completionRange = Range (Position 0 0) (Position 0 0) + , completionWorkingDir = fp + , completionFileName = "test" + } + +filePathComplTestDir :: FilePath +filePathComplTestDir = addTrailingPathSeparator $ testDataDir "filepath-completions" + +runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir + +runCabalSession :: FilePath -> Session a -> IO a +runCabalSession subdir = + failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) + +testDataDir :: FilePath +testDataDir = "plugins" "hls-cabal-plugin" "test" "testdata" + +-- | list comparison where the order in the list is irrelevant +(@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion +(@?==) l1 l2 = sort l1 @?= sort l2 diff --git a/plugins/hls-cabal-plugin/test/testdata/completer.cabal b/plugins/hls-cabal-plugin/test/testdata/completer.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/completer.cabal @@ -0,0 +1,12 @@ +cabal-version: 3.4 +name: test-hls +version: 0.1.0.0 +maintainer: milky +synopsis: example cabal file :) +license: Apache-2.0 +build-type: Simple + +be + +library + lib diff --git a/plugins/hls-cabal-plugin/test/testdata/exposed.cabal b/plugins/hls-cabal-plugin/test/testdata/exposed.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/exposed.cabal @@ -0,0 +1,40 @@ +cabal-version: 3.4 +name: test-hls +version: 0.1.0.0 +maintainer: milky +category: Dev +synopsis: dsasd +license: MIT +license-file: ./LICENSE.md + +library + hs-source-dirs: ./src-modules/Dir1/ + exposed-modules: + build-depends: base + default-language: Haskell2010 + +benchmark benchie + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base + hs-source-dirs: ./src-modules/ + exposed-modules: + +executable executie + main-is: Main.hs + build-depends: base + hs-source-dirs: ./src-modules/ ./src-modules/Dir1/ + exposed-modules: + +executable exe-not-so-cutie + main-is: Main.hs + build-depends: base + hs-source-dirs: ./src-modules/Dir1/Dir2/ ./src-modules/Dir1/Dir3 + exposed-modules: + +test-suite suitor + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base + hs-source-dirs: "./src-modules/Dir1/Dir3/Dir4" + exposed-modules: diff --git a/plugins/hls-cabal-plugin/test/testdata/filepath-completions/Content.hs b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/Content.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/Content.hs diff --git a/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f1.txt b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f1.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f1.txt @@ -0,0 +1,1 @@ +test text file diff --git a/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f2.hs b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/dir1/f2.hs @@ -0,0 +1,1 @@ +-- test haskell file diff --git a/plugins/hls-cabal-plugin/test/testdata/filepath-completions/main-is.cabal b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/main-is.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/main-is.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.4 +name: test-hls +version: 0.1.0.0 +maintainer: milky +synopsis: example cabal file :) +license: Apache-2.0 +build-type: Simple + +executable exe + hs-source-dirs: ./dir1/ + main-is: diff --git a/plugins/hls-cabal-plugin/test/testdata/filepath-completions/textfile.txt b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/textfile.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/filepath-completions/textfile.txt @@ -0,0 +1,1 @@ +test text file diff --git a/plugins/hls-cabal-plugin/test/testdata/invalid.cabal b/plugins/hls-cabal-plugin/test/testdata/invalid.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/invalid.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: invalid +version: 0.1.0.0 +license: BSD3 + +library + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: licenseCodeAction +version: 0.1.0.0 +license: BSD3 + +library + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction2.cabal b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction2.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction2.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: licenseCodeAction2 +version: 0.1.0.0 +license: APAHE + +library + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs @@ -0,0 +1,4 @@ +module A where + +-- definitions don't matter here. +foo = 1 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +library + build-depends: base + hs-source-dirs: . + exposed-modules: A + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple.cabal b/plugins/hls-cabal-plugin/test/testdata/simple.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.0 +name: hls-cabal-plugin +version: 0.1.0.0 +synopsis: +homepage: +license: MIT +license-file: LICENSE +author: Fendor +maintainer: fendor@posteo.de +category: Development +extra-source-files: CHANGELOG.md + +library + exposed-modules: IDE.Plugin.Cabal + build-depends: base ^>=4.14.3.0 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite hls-cabal-plugin-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base ^>=4.14.3.0 diff --git a/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir2/File2.hs b/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir2/File2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir2/File2.hs diff --git a/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir3/Dir4/File3.hs b/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir3/Dir4/File3.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/src-modules/Dir1/Dir3/Dir4/File3.hs diff --git a/plugins/hls-cabal-plugin/test/testdata/src-modules/File1.hs b/plugins/hls-cabal-plugin/test/testdata/src-modules/File1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/src-modules/File1.hs diff --git a/plugins/hls-cabal-plugin/test/testdata/src-modules/test.cabal b/plugins/hls-cabal-plugin/test/testdata/src-modules/test.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/src-modules/test.cabal diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.CallHierarchy (descriptor) where + +import Development.IDE +import qualified Ide.Plugin.CallHierarchy.Internal as X +import Ide.Types +import Language.LSP.Protocol.Message + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId "Provides call-hierarchy support in Haskell") + { Ide.Types.pluginHandlers = + mkPluginHandler SMethod_TextDocumentPrepareCallHierarchy X.prepareCallHierarchy + <> mkPluginHandler SMethod_CallHierarchyIncomingCalls X.incomingCalls + <> mkPluginHandler SMethod_CallHierarchyOutgoingCalls X.outgoingCalls + } diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.CallHierarchy.Internal ( + prepareCallHierarchy +, incomingCalls +, outgoingCalls +) where + +import Control.Lens (Lens', (^.)) +import Control.Monad.IO.Class +import Data.Aeson as A +import Data.Functor ((<&>)) +import Data.List (groupBy, sortBy) +import qualified Data.Map as M +import Data.Maybe +import Data.Ord (comparing) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat as Compat +import Development.IDE.Spans.AtPoint +import HieDb (Symbol (Symbol)) +import qualified Ide.Plugin.CallHierarchy.Query as Q +import Ide.Plugin.CallHierarchy.Types +import Ide.Plugin.Error +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Prelude hiding (mod, span) +import Text.Read (readMaybe) + +-- | Render prepare call hierarchy request. +prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy +prepareCallHierarchy state _ param = do + nfp <- getNormalizedFilePathE (param ^. (L.textDocument . L.uri)) + items <- liftIO + $ runAction "CallHierarchy.prepareHierarchy" state + $ prepareCallHierarchyItem nfp (param ^. L.position) + pure $ InL items + +prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] +prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case + Nothing -> mempty + Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp + +prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem] +prepareByAst hf pos nfp = + case listToMaybe $ pointCommand hf pos extract of + Nothing -> mempty + Just infos -> mapMaybe (construct nfp hf) infos + +extract :: HieAST a -> [(Identifier, [ContextInfo], Span)] +extract ast = let span = nodeSpan ast + infos = M.toList $ M.map (S.toList . identInfo) (Compat.getNodeIds ast) + in [(ident, contexts, span) | (ident, contexts) <- infos] + +recFieldInfo, declInfo, valBindInfo, classTyDeclInfo, + useInfo, patternBindInfo, tyDeclInfo, matchBindInfo :: [ContextInfo] -> Maybe ContextInfo +recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- ctxs] +declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- ctxs] +valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- ctxs] +classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- ctxs] +useInfo ctxs = listToMaybe [Use | Use <- ctxs] +patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- ctxs] +tyDeclInfo ctxs = listToMaybe [TyDecl | TyDecl <- ctxs] +matchBindInfo ctxs = listToMaybe [MatchBind | MatchBind <- ctxs] + +construct :: NormalizedFilePath -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem +construct nfp hf (ident, contexts, ssp) + | isInternalIdentifier ident = Nothing + + | Just (RecField RecFieldDecl _) <- recFieldInfo contexts + -- ignored type span + = Just $ mkCallHierarchyItem' ident SymbolKind_Field ssp ssp + + | isJust (matchBindInfo contexts) && isNothing (valBindInfo contexts) + = Just $ mkCallHierarchyItem' ident SymbolKind_Function ssp ssp + + | Just ctx <- valBindInfo contexts + = Just $ case ctx of + ValBind _ _ span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp + _ -> mkCallHierarchyItem' ident skUnknown ssp ssp + + | Just ctx <- declInfo contexts + = Just $ case ctx of + Decl ClassDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SymbolKind_Constructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SymbolKind_Struct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem' ident SymbolKind_TypeParameter (renderSpan span) ssp + _ -> mkCallHierarchyItem' ident skUnknown ssp ssp + + | Just (ClassTyDecl span) <- classTyDeclInfo contexts + = Just $ mkCallHierarchyItem' ident SymbolKind_Method (renderSpan span) ssp + + | Just (PatternBind _ _ span) <- patternBindInfo contexts + = Just $ mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp + + | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SymbolKind_Interface ssp ssp + + | Just _ <- tyDeclInfo contexts = renderTyDecl + + | otherwise = Nothing + where + renderSpan (Just span) = span + renderSpan _ = ssp + + -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97 + -- There is no longer an unknown symbol, thus using SymbolKind_Function + -- as this is the call-hierarchy plugin + skUnknown = SymbolKind_Function + + mkCallHierarchyItem' = mkCallHierarchyItem nfp + + isInternalIdentifier = \case + Left _ -> False + Right name -> isInternalName name + + renderTyDecl = case ident of + Left _ -> Nothing + Right name -> case getNameBinding name (getAsts hf) of + Nothing -> Nothing + Just sp -> listToMaybe $ prepareByAst hf (realSrcSpanToRange sp ^. L.start) nfp + +mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem +mkCallHierarchyItem nfp ident kind span selSpan = + CallHierarchyItem + (T.pack $ optimizeDisplay $ identifierName ident) + kind + Nothing + (Just $ T.pack $ identifierToDetail ident) + (fromNormalizedUri $ normalizedFilePathToUri nfp) + (realSrcSpanToRange span) + (realSrcSpanToRange selSpan) + (toJSON . show <$> mkSymbol ident) + where + identifierToDetail :: Identifier -> String + identifierToDetail = \case + Left modName -> moduleNameString modName + Right name -> (moduleNameString . moduleName . nameModule) name + + identifierName :: Identifier -> String + identifierName = \case + Left modName -> moduleNameString modName + Right name -> occNameString $ nameOccName name + + optimizeDisplay :: String -> String + optimizeDisplay name -- Optimize display for DuplicateRecordFields + | "$sel:" == take 5 name = drop 5 name + | otherwise = name + +mkSymbol :: Identifier -> Maybe Symbol +mkSymbol = \case + Left _ -> Nothing + Right name -> Just $ Symbol (occName name) (nameModule name) + +---------------------------------------------------------------------- +-------------- Incoming calls and outgoing calls --------------------- +---------------------------------------------------------------------- + +-- | Render incoming calls request. +incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls +incomingCalls state _pluginId param = do + calls <- liftIO + $ runAction "CallHierarchy.incomingCalls" state + $ queryCalls + (param ^. L.item) + Q.incomingCalls + mkCallHierarchyIncomingCall + (mergeCalls CallHierarchyIncomingCall L.from) + pure $ InL calls + where + mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) + mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall + +-- | Render outgoing calls request. +outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls +outgoingCalls state _pluginId param = do + calls <- liftIO + $ runAction "CallHierarchy.outgoingCalls" state + $ queryCalls + (param ^. L.item) + Q.outgoingCalls + mkCallHierarchyOutgoingCall + (mergeCalls CallHierarchyOutgoingCall L.to) + pure $ InL calls + where + mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) + mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall + +-- | Merge calls from the same place +mergeCalls :: + L.HasFromRanges s [Range] + => (CallHierarchyItem -> [Range] -> s) + -> Lens' s CallHierarchyItem + -> [s] + -> [s] +mergeCalls constructor target = + concatMap merge + . groupBy (\a b -> a ^. target == b ^. target) + . sortBy (comparing (^. target)) + where + merge [] = [] + merge calls@(call:_) = + let ranges = concatMap (^. L.fromRanges) calls + in [constructor (call ^. target) ranges] + +mkCallHierarchyCall :: (CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a) +mkCallHierarchyCall mk v@Vertex{..} = do + let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1) + nfp = toNormalizedFilePath' hieSrc + range = mkRange + (fromIntegral $ casl - 1) + (fromIntegral $ casc - 1) + (fromIntegral $ cael - 1) + (fromIntegral $ caec - 1) + + prepareCallHierarchyItem nfp pos >>= + \case + [item] -> pure $ Just $ mk item [range] + _ -> do + ShakeExtras{withHieDb} <- getShakeExtras + sps <- liftIO (withHieDb (`Q.getSymbolPosition` v)) + case sps of + (x:_) -> do + items <- prepareCallHierarchyItem + nfp + (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) + case items of + [item] -> pure $ Just $ mk item [range] + _ -> pure Nothing + [] -> pure Nothing + +-- | Unified queries include incoming calls and outgoing calls. +queryCalls :: + CallHierarchyItem + -> (HieDb -> Symbol -> IO [Vertex]) + -> (Vertex -> Action (Maybe a)) + -> ([a] -> [a]) + -> Action [a] +queryCalls item queryFunc makeFunc merge + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + ShakeExtras{withHieDb} <- getShakeExtras + maySymbol <- getSymbol nfp + case maySymbol of + Nothing -> pure mempty + Just symbol -> do + vs <- liftIO $ withHieDb (`queryFunc` symbol) + items <- catMaybes <$> mapM makeFunc vs + pure $ merge items + | otherwise = pure mempty + where + uri = item ^. L.uri + pos = item ^. (L.selectionRange . L.start) + + getSymbol nfp = case item ^. L.data_ of + Just xdata -> case fromJSON xdata of + A.Success (symbolStr :: String) -> maybe (getSymbolFromAst nfp pos) (pure . pure) $ readMaybe symbolStr + A.Error _ -> getSymbolFromAst nfp pos + Nothing -> getSymbolFromAst nfp pos -- Fallback if xdata lost, some editor(VSCode) will drop it + + getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) + getSymbolFromAst nfp pos_ = use GetHieAst nfp <&> \case + Nothing -> Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos_ extract of + Just infos -> mkSymbol . fst3 =<< listToMaybe infos + Nothing -> Nothing diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.CallHierarchy.Query ( + incomingCalls +, outgoingCalls +, getSymbolPosition +) where + +import qualified Data.Text as T +import Database.SQLite.Simple +import Development.IDE.GHC.Compat +import HieDb (HieDb (getConn), Symbol (..)) +import Ide.Plugin.CallHierarchy.Types +import Prelude hiding (mod) + +incomingCalls :: HieDb -> Symbol -> IO [Vertex] +incomingCalls (getConn -> conn) symbol = do + let (o, m, u) = parseSymbol symbol + query conn + (Query $ T.pack $ concat + [ "SELECT mods.mod, decls.occ, mods.hs_src, decls.sl, decls.sc, " + , "decls.el, decls.ec, refs.sl, refs.sc, refs.el, refs.ec " + , "FROM refs " + , "JOIN decls ON decls.hieFile = refs.hieFile " + , "JOIN mods ON mods.hieFile = decls.hieFile " + , "where " + , "(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) " + , "AND " + , "(decls.occ != ? OR mods.mod != ? OR mods.unit != ?) " + , "AND " + , "((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) " + , "AND " + ,"((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" + ] + ) (o, m, u, o, m, u) + +outgoingCalls :: HieDb -> Symbol -> IO [Vertex] +outgoingCalls (getConn -> conn) symbol = do + let (o, m, u) = parseSymbol symbol + query conn + (Query $ T.pack $ concat + [ "SELECT rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, " + , "refs.sl, refs.sc, refs.el, refs.ec " + , "from refs " + , "JOIN defs ON defs.occ = refs.occ " + , "JOIN decls rd ON rd.hieFile = defs.hieFile AND rd.occ = defs.occ " + , "JOIN mods rm ON rm.mod = refs.mod AND rm.unit = refs.unit AND rm.hieFile = defs.hieFile " + , "JOIN decls ON decls.hieFile = refs.hieFile " + , "JOIN mods ON mods.hieFile = decls.hieFile " + , "where " + , "(decls.occ = ? AND mods.mod = ? AND mods.unit = ?) " + , "AND " + , "(defs.occ != ? OR rm.mod != ? OR rm.unit != ?) " + , "AND " + , "((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) " + , "AND " + , "((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" + ] + ) (o, m, u, o, m, u) + +getSymbolPosition :: HieDb -> Vertex -> IO [SymbolPosition] +getSymbolPosition (getConn -> conn) Vertex{..} = do + query conn + (Query $ T.pack $ concat + [ "SELECT refs.sl, refs.sc from refs where " + , "(occ = ?) " + , "AND " + , "((refs.sl = ? AND refs.sc > ?) OR (refs.sl > ?)) " + , "AND " + , "((refs.el = ? AND refs.ec <= ?) OR (refs.el < ?))" + ] + ) (occ, sl, sc, sl, el, ec, el) + +parseSymbol :: Symbol -> (OccName, ModuleName, Unit) +parseSymbol Symbol{..} = + let o = symName + m = moduleName symModule + u = moduleUnit symModule + in (o, m, u) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Ide.Plugin.CallHierarchy.Types where + +import Data.Aeson +import Database.SQLite.Simple +import Database.SQLite.Simple.ToField +import GHC.Generics + +data Vertex = Vertex { + mod :: String +, occ :: String +, hieSrc :: FilePath +, sl :: Int -- ^ start line +, sc :: Int -- ^ start character +, el :: Int -- ^ end line +, ec :: Int -- ^ end character +, casl :: Int -- ^ sl for call appear +, casc :: Int -- ^ sc for call appear +, cael :: Int -- ^ el for call appear +, caec :: Int -- ^ ec for call appear +} deriving (Eq, Show, Generic, FromJSON, ToJSON) + +instance ToRow Vertex where + toRow (Vertex a b c d e f g h i j k) = + [ toField a, toField b, toField c, toField d + , toField e, toField f, toField g, toField h + , toField i, toField j, toField k + ] + +instance FromRow Vertex where + fromRow = Vertex <$> field <*> field <*> field + <*> field <*> field <*> field + <*> field <*> field <*> field + <*> field <*> field + +data SymbolPosition = SymbolPosition { + psl :: Int +, psc :: Int +} deriving (Eq, Show, Generic, FromJSON, ToJSON) + +instance ToRow SymbolPosition where + toRow (SymbolPosition a b) = toRow (a, b) + +instance FromRow SymbolPosition where + fromRow = SymbolPosition <$> field <*> field diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Lens (set, (^.)) +import Control.Monad.Extra +import qualified Data.Aeson as Aeson +import Data.Functor ((<&>)) +import Data.List (sort, tails) +import qualified Data.Map as M +import qualified Data.Text as T +import Development.IDE.Test +import Ide.Plugin.CallHierarchy +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Test as Test +import System.FilePath +import Test.Hls + +plugin :: PluginTestDescriptor () +plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" + +main :: IO () +main = defaultTestRunner $ + testGroup "Call Hierarchy" + [ prepareCallHierarchyTests + , incomingCallsTests + , outgoingCallsTests + ] + +prepareCallHierarchyTests :: TestTree +prepareCallHierarchyTests = + testGroup + "Prepare Call Hierarchy" + [ testCase "variable" $ do + let contents = T.unlines ["a=3"] + range = mkRange 0 0 0 3 + selRange = mkRange 0 0 0 1 + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange + oneCaseWithCreate contents 0 0 expected + , testCase "function" $ do + let contents = T.unlines ["a=(+)"] + range = mkRange 0 0 0 5 + selRange = mkRange 0 0 0 1 + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange + oneCaseWithCreate contents 0 0 expected + , testCase "datatype" $ do + let contents = T.unlines ["data A=A"] + range = mkRange 0 0 0 8 + selRange = mkRange 0 5 0 6 + expected = mkCallHierarchyItemT "A" SymbolKind_Struct range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A"] + range = mkRange 0 7 0 8 + selRange = mkRange 0 7 0 8 + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange + oneCaseWithCreate contents 0 7 expected +-- , testCase "record" $ do +-- let contents = T.unlines ["data A=A{a::Int}"] +-- range = mkRange 0 9 0 10 +-- selRange = mkRange 0 9 0 10 +-- expected = mkCallHierarchyItemV "a" SymbolKind_Field range selRange +-- oneCaseWithCreate contents 0 9 expected + , testCase "type operator" $ do + let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] + range = mkRange 1 0 1 15 + selRange = mkRange 1 5 1 9 + expected = mkCallHierarchyItemT "><" SymbolKind_TypeParameter range selRange + oneCaseWithCreate contents 1 5 expected + , testCase "type class" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + range = mkRange 0 0 0 29 + selRange = mkRange 0 6 0 7 + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange + oneCaseWithCreate contents 0 6 expected + , testCase "type class method" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + range = mkRange 0 16 0 29 + selRange = mkRange 0 16 0 17 + expected = mkCallHierarchyItemV "a" SymbolKind_Method range selRange + oneCaseWithCreate contents 0 16 expected + , testCase "type class instance" $ do + let contents = T.unlines ["class A a where", "instance A () where"] + range = mkRange 1 9 1 10 + selRange = mkRange 1 9 1 10 + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange + oneCaseWithCreate contents 1 9 expected + , testGroup "type family" + [ testCase "1" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] + range = mkRange 1 0 1 13 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 12 expected + , testCase "2" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] + range = mkRange 1 0 1 15 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 12 expected + ] + , testCase "type family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + range = mkRange 2 14 2 23 + selRange = mkRange 2 14 2 15 + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange + oneCaseWithCreate contents 2 14 expected + , testGroup "data family" + [ testCase "1" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] + range = mkRange 1 0 1 11 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 12 expected + , testCase "2" $ do + let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] + range = mkRange 1 0 1 11 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 12 expected + ] + , testCase "data family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "data family A a" + , "data instance A () = A()" + ] + range = mkRange 2 14 2 24 + selRange = mkRange 2 14 2 15 + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange + oneCaseWithCreate contents 2 14 expected + , testCase "pattern" $ do + let contents = T.unlines ["Just x = Just 3"] + range = mkRange 0 0 0 15 + selRange = mkRange 0 5 0 6 + expected = mkCallHierarchyItemV "x" SymbolKind_Function range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "pattern with type signature" $ do + let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] + range = mkRange 1 0 1 12 + selRange = mkRange 1 0 1 1 + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 0 expected + , testCase "type synonym" $ do + let contents = T.unlines ["type A=Bool"] + range = mkRange 0 0 0 11 + selRange = mkRange 0 5 0 6 + expected = mkCallHierarchyItemT "A" SymbolKind_TypeParameter range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "GADT" $ do + let contents = T.unlines + [ "{-# LANGUAGE GADTs #-}" + , "data A where A :: Int -> A" + ] + range = mkRange 1 13 1 26 + selRange = mkRange 1 13 1 14 + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange + oneCaseWithCreate contents 1 13 expected + , testGroup "type signature" + [ testCase "next line" $ do + let contents = T.unlines ["a::Int", "a=3"] + range = mkRange 1 0 1 3 + selRange = mkRange 1 0 1 1 + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange + oneCaseWithCreate contents 0 0 expected + , testCase "multi functions" $ do + let contents = T.unlines [ "a,b::Int", "a=3", "b=4"] + range = mkRange 2 0 2 3 + selRange = mkRange 2 0 2 1 + expected = mkCallHierarchyItemV "b" SymbolKind_Function range selRange + oneCaseWithCreate contents 0 2 expected + ] + , testCase "multi pattern" $ do + let contents = T.unlines + [ "f (Just _) = ()" + , "f Nothing = ()" + ] + range = mkRange 1 0 1 1 + selRange = mkRange 1 0 1 1 + expected = mkCallHierarchyItemV "f" SymbolKind_Function range selRange + oneCaseWithCreate contents 1 0 expected + ] + +incomingCallsTests :: TestTree +incomingCallsTests = + testGroup "Incoming Calls" + [ testGroup "single file" + [ testCase "xdata unavailable" $ + runSessionWithServer def plugin testDataDir $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + waitForIndex (testDataDir "A.hs") + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) + let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]] + item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) + let itemNoData = set L.data_ Nothing item' + res <- Test.incomingCalls (mkIncomingCallsParam itemNoData) + liftIO $ sort expected @=? sort res + closeDoc doc + , testCase "xdata available" $ do + let contents = T.unlines ["a=3","b=a"] + positions = [(1, 0)] + ranges = [mkRange 1 2 1 3] + incomingCallTestCase contents 0 1 positions ranges + , testGroup "data" + [ testCase "data type" $ do + let contents = T.unlines ["data A=A"] + positions = [] + ranges = [] + incomingCallTestCase contents 0 5 positions ranges + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A"] + positions = [(0, 5)] + ranges = [mkRange 0 7 0 8] + incomingCallTestCase contents 0 7 positions ranges + -- , testCase "record" $ do + -- let contents = T.unlines ["data A=A{a::Int}"] + -- positions = [(0, 5), (0, 7)] + -- ranges = [mkRange 0 9 0 10, mkRange 0 9 0 10] + -- incomingCallTestCase contents 0 9 positions ranges + ] + , testCase "function" $ do + let contents = T.unlines ["a=(+)"] + positions = [(0, 0)] + ranges = [mkRange 0 2 0 5] + incomingCallTestCase contents 0 3 positions ranges + , testCase "type operator" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeOperators #-}" + , "type (><)=Int"] + positions = [(1, 5)] + ranges = [mkRange 1 10 1 13] + incomingCallTestCase contents 1 10 positions ranges + , testGroup "type class" + [ testCase "type class method" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + positions = [(0, 6)] + ranges = [mkRange 0 16 0 17] + incomingCallTestCase contents 0 16 positions ranges + , testCase "type class instance" $ do + let contents = T.unlines + [ "class A a where a :: a -> Int" + , "instance A () where a = const 3"] + positions = [(0, 6)] + ranges = [mkRange 0 16 0 17] + incomingCallTestCase contents 1 20 positions ranges + , testCase "goto typeclass instance" $ do + let contents = T.unlines + [ "class F a where f :: a" + , "instance F Bool where f = x" + , "instance F Int where f = 3" + , "x = True" + ] + positions = [(1, 22)] + ranges = [mkRange 1 26 1 27] + incomingCallTestCase contents 3 0 positions ranges + ] + , testCase "type family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "type family A a" + , "type instance A Int = Char" + ] + positions = [(2, 14)] + ranges = [mkRange 2 22 2 26] + incomingCallTestCase contents 2 22 positions ranges + , testCase "GADT" $ do + let contents = T.unlines + [ "{-# LANGUAGE GADTs #-}" + , "data A where B :: Int -> A" + ] + positions = [(1, 5)] + ranges = [mkRange 1 13 1 14] + incomingCallTestCase contents 1 13 positions ranges + , testCase "multi pattern" $ do + let contents = T.unlines + [ "f 1 = 1" + , "f 2 = 2" + , "g = f" + ] + positions = [(2, 0)] + ranges = [mkRange 2 4 2 5] + incomingCallTestCase contents 1 0 positions ranges + ] + , testGroup "multi file" + [ testCase "1" $ do + let mp = M.fromList [ + ("A.hs", [ ((5, 0), mkRange 5 7 5 11) + , ((6, 0), mkRange 6 7 6 11) + , ((8, 0), mkRange 9 25 9 29) + ] + )] + incomingCallMultiFileTestCase "A.hs" 4 0 mp + , testCase "2" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 4 13 4 16) + , ((8, 0), mkRange 10 7 10 10) + ] + ) + , ("B.hs", [ ((4, 0), mkRange 4 8 4 11)]) + ] + incomingCallMultiFileTestCase "C.hs" 2 0 mp + ] + ] + +outgoingCallsTests :: TestTree +outgoingCallsTests = + testGroup "Outgoing Calls" + [ testGroup "single file" + [ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> + runSessionWithServer def plugin dir $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + waitForIndex (dir "A.hs") + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) + let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]] + item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) + let itemNoData = set L.data_ Nothing item' + res <- Test.outgoingCalls (mkOutgoingCallsParam itemNoData) + liftIO $ sort expected @=? sort res + closeDoc doc + , testCase "xdata available" $ do + let contents = T.unlines ["a=3", "b=a"] + positions = [(0, 0)] + ranges = [mkRange 1 2 1 3] + outgoingCallTestCase contents 1 0 positions ranges + , testGroup "data" + [ testCase "data type" $ do + let contents = T.unlines ["data A=A"] + positions = [(0, 7)] + ranges = [mkRange 0 7 0 8] + outgoingCallTestCase contents 0 5 positions ranges + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A"] + positions = [] + ranges = [] + outgoingCallTestCase contents 0 7 positions ranges + -- , testCase "record" $ do + -- let contents = T.unlines ["data A=A{a::Int}"] + -- positions = [(0, 7), (0, 9)] + -- ranges = [mkRange 0 7 0 8, mkRange 0 9 0 10] + -- outgoingCallTestCase contents 0 5 positions ranges + ] + , testCase "function" $ do + let contents = T.unlines ["a=3", "b=4", "c=a+b"] + positions = [(0, 1), (1, 1)] + ranges = [mkRange 2 2 2 3, mkRange 2 4 2 5] + outgoingCallTestCase contents 2 0 positions ranges + , testCase "type synonym" $ do + let contents = T.unlines ["data A", "type B=A"] + positions = [(0, 5)] + ranges = [mkRange 1 7 1 8] + outgoingCallTestCase contents 1 5 positions ranges + , testCase "type class instance" $ do + let contents = T.unlines + [ "class A a where a :: a" + , "instance A () where a = ()" + ] + positions = [(0, 16)] + ranges = [mkRange 0 16 0 17] + outgoingCallTestCase contents 1 9 positions ranges + , testCase "data family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "data family A a" + , "data instance A () = B" + ] + positions = [(2, 21)] + ranges = [mkRange 2 21 2 22] + outgoingCallTestCase contents 1 12 positions ranges + , testCase "GADT" $ do + let contents = T.unlines ["{-# LANGUAGE GADTs #-}", "data A where B :: A"] + positions = [(1, 13)] + ranges = [mkRange 1 13 1 14] + outgoingCallTestCase contents 1 5 positions ranges + ] + , testGroup "multi file" + [ testCase "1" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 5 7 5 11)]) + , ("B.hs", [ ((4, 0), mkRange 5 14 5 17)]) + , ("C.hs", [ ((3, 0), mkRange 5 20 5 23)]) + ] + outgoingCallMultiFileTestCase "A.hs" 5 0 mp + , testCase "2" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 9 25 9 29) + , ((5, 0), mkRange 10 25 10 29) + ] + ) + , ("B.hs", [ ((2, 9), mkRange 9 2 9 3) + , ((2, 13), mkRange 10 2 10 3) + , ((4, 0), mkRange 9 7 9 10) + , ((5, 0), mkRange 9 13 9 16) + , ((6, 0), mkRange 9 19 9 22) + ] + ) + , ("C.hs", [ ((2, 0), mkRange 10 7 10 10) + , ((3, 0), mkRange 10 13 10 16) + , ((4, 0), mkRange 10 19 10 22) + ] + ) + ] + outgoingCallMultiFileTestCase "A.hs" 8 0 mp + ] + ] + + +incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion +incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> + runSessionWithServer def plugin dir $ do + doc <- createDoc "A.hs" "haskell" contents + waitForIndex (dir "A.hs") + items <- concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) + <&> map (, range) + ) + (zip positions ranges) + let expected = map mkCallHierarchyIncomingCall items + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.incomingCalls (mkIncomingCallsParam item) + liftIO $ sort expected @=? sort res + closeDoc doc + +incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion +incomingCallMultiFileTestCase filepath queryX queryY mp = + runSessionWithServer def plugin testDataDir $ do + doc <- openDoc filepath "haskell" + waitForIndex (testDataDir filepath) + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do + p <- openDoc fp "haskell" + waitForKickDone + concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) + <&> map (, range) + ) pr) mp + let expected = map mkCallHierarchyIncomingCall items + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.incomingCalls (mkIncomingCallsParam item) + liftIO $ sort expected @=? sort res + closeDoc doc + +outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion +outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> + runSessionWithServer def plugin dir $ do + doc <- createDoc "A.hs" "haskell" contents + waitForIndex (dir "A.hs") + items <- concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) + <&> map (, range) + ) + (zip positions ranges) + let expected = map mkCallHierarchyOutgoingCall items + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.outgoingCalls (mkOutgoingCallsParam item) + liftIO $ sort expected @=? sort res + closeDoc doc + +outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion +outgoingCallMultiFileTestCase filepath queryX queryY mp = + runSessionWithServer def plugin testDataDir $ do + doc <- openDoc filepath "haskell" + waitForIndex (testDataDir filepath) + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do + p <- openDoc fp "haskell" + waitForKickDone + concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) + <&> map (, range) + ) pr) mp + let expected = map mkCallHierarchyOutgoingCall items + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.outgoingCalls (mkOutgoingCallsParam item) + liftIO $ sort expected @=? sort res + closeDoc doc + +oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion +oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> + runSessionWithServer def plugin dir $ do + doc <- createDoc "A.hs" "haskell" contents + waitForIndex (dir "A.hs") + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + liftIO $ expected (doc ^. L.uri) item + closeDoc doc + +expectOneElement :: [a] -> Session a +expectOneElement = \case + [x] -> pure x + xs -> liftIO . assertFailure $ "Expecting exactly one element, but got " ++ show (length xs) + +mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion +mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do + assertHierarchyItem name name' + assertHierarchyItem kind kind' + assertHierarchyItem tags tags' + assertHierarchyItem detail detail' + assertHierarchyItem uri uri' + assertHierarchyItem range range' + assertHierarchyItem selRange selRange' + case xdata' of + Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata) + Just v -> case Aeson.fromJSON v of + Aeson.Success v' -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v') + Aeson.Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err) + where + tags = Nothing + detail = Just "Main" + assertHierarchyItem :: forall a. (Eq a, Show a) => a -> a -> Assertion + assertHierarchyItem = assertEqual ("In " ++ show c ++ ", got unexpected value for field") + xdata = T.pack prefix <> ":" <> name <> ":Main:main" + +mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV :: + T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion +mkCallHierarchyItemC = mkCallHierarchyItem' "c" +mkCallHierarchyItemT = mkCallHierarchyItem' "t" +mkCallHierarchyItemV = mkCallHierarchyItem' "v" + +mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall +mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item [range] + +mkCallHierarchyOutgoingCall :: (CallHierarchyItem, Range) -> CallHierarchyOutgoingCall +mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item [range] + +testDataDir :: FilePath +testDataDir = "plugins" "hls-call-hierarchy-plugin" "test" "testdata" + +mkPrepareCallHierarchyParam :: TextDocumentIdentifier -> Int -> Int -> CallHierarchyPrepareParams +mkPrepareCallHierarchyParam doc x y = CallHierarchyPrepareParams doc (Position (fromIntegral x) (fromIntegral y)) Nothing + +mkIncomingCallsParam :: CallHierarchyItem -> CallHierarchyIncomingCallsParams +mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing + +mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams +mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing + +-- Wait for a special test message emitted by ghcide when a file is indexed, +-- so that call hierarchy can safely query the database. +waitForIndex :: FilePath -> Session () +waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals + where + -- fp1 may be relative, in that case we check that it is a suffix of the + -- filepath from the message + lenientEquals :: FilePath -> Bool + lenientEquals fp2 + | isRelative fp1 = any (equalFilePath fp1 . joinPath) $ tails $ splitDirectories fp2 + | otherwise = equalFilePath fp1 fp2 + diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs @@ -0,0 +1,11 @@ +module A where +import B +import C + +foo1 = B.a + C.a +foo2 = foo1 + B.a + C.b +foo3 = foo1 + foo2 + C.c + +bar x = case x of + A -> B.a + B.b + B.c + foo1 + B -> C.a + C.b + C.c + foo2 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where +import qualified C +data T = A | B + +a = 3 + C.a +b = 4 +c = 5 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs @@ -0,0 +1,5 @@ +module C where + +a = 3 +b = 4 +c = 5 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml b/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["A", "B", "C"]}} diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +-- | An HLS plugin to provide code actions to change type signatures +module Ide.Plugin.ChangeTypeSignature (descriptor + -- * For Unit Tests + , errorMessageRegexes + ) where + +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (asum) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (realSrcSpanToRange) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) +import Development.IDE.Core.Service (IdeState) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util (printOutputable) +import Generics.SYB (extQ, something) +import Ide.Plugin.Error (PluginError, + getNormalizedFilePathE) +import Ide.Types (PluginDescriptor (..), + PluginId (PluginId), + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Text.Regex.TDFA ((=~)) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) } + +codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = do + nfp <- getNormalizedFilePathE uri + decls <- getDecls plId ideState nfp + let actions = mapMaybe (generateAction plId uri decls) diags + pure $ InL actions + +getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] +getDecls (PluginId changeTypeSignatureId) state = + runActionE (T.unpack changeTypeSignatureId <> ".GetParsedModule") state + . fmap (hsmodDecls . unLoc . pm_parsed_source) + . useE GetParsedModule + +-- | Text representing a Declaration's Name +type DeclName = Text +-- | The signature provided by GHC Error Message (Expected type) +type ExpectedSig = Text +-- | The signature provided by GHC Error Message (Actual type) +type ActualSig = Text + +-- | DataType that encodes the necessary information for changing a type signature +data ChangeSignature = ChangeSignature { + -- | The expected type based on Signature + expectedType :: ExpectedSig + -- | the Actual Type based on definition + , actualType :: ActualSig + -- | the declaration name to be updated + , declName :: DeclName + -- | the location of the declaration signature + , declSrcSpan :: RealSrcSpan + -- | the diagnostic to solve + , diagnostic :: Diagnostic + } + +-- | Create a CodeAction from a Diagnostic +generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction) +generateAction plId uri decls diag = changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls diag + +-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan +diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature +diagnosticToChangeSig decls diagnostic = do + -- regex match on the GHC Error Message + (expectedType, actualType, declName) <- matchingDiagnostic diagnostic + -- Find the definition and it's location + declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName) + pure $ ChangeSignature{..} + + +-- | If a diagnostic has the proper message create a ChangeSignature from it +matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName) +matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes + where + unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName) + -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match + unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name) + unwrapMatch _ = Nothing + +-- | List of regexes that match various Error Messages +errorMessageRegexes :: [Text] +errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests + "Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’" + , "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’" + -- GHC >9.2 version of the first error regex + , "Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’" + ] + +-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches +-- both the name given and the Expected Type, and return the type signature location +findSigLocOfStringDecl :: [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan +findSigLocOfStringDecl decls expectedType declName = something (const Nothing `extQ` findSig `extQ` findLocalSig) decls + where + -- search for Top Level Signatures + findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan + findSig = \case + L (locA -> (RealSrcSpan rss _)) (SigD _ sig) -> case sig of + ts@(TypeSig _ idsSig _) -> isMatch ts idsSig >> pure rss + _ -> Nothing + _ -> Nothing + + -- search for Local Signatures + findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan + findLocalSig = \case + (L (locA -> (RealSrcSpan rss _)) ts@(TypeSig _ idsSig _)) -> isMatch ts idsSig >> pure rss + _ -> Nothing + + -- Does the declName match? and does the expected signature match? + isMatch ts idsSig = do + ghcSig <- sigToText ts + guard (any compareId idsSig && expectedType == ghcSig) + + -- Given an IdP check to see if it matches the declName + compareId (L _ id') = declName == occNameString (occName id') + + +-- | Pretty Print the Type Signature (to validate GHC Error Message) +sigToText :: Sig GhcPs -> Maybe Text +sigToText = \case + ts@TypeSig {} -> Just $ stripSignature $ printOutputable ts + _ -> Nothing + +stripSignature :: Text -> Text +-- for whatever reason incoming signatures MAY have new lines after "::" or "=>" +stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig + -- remove constraints + then T.strip $ snd $ T.breakOnEnd " => " sig + else T.strip $ snd $ T.breakOnEnd " :: " sig + +changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction +changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} = + InR CodeAction { _title = mkChangeSigTitle declName actualType + , _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId)) + , _diagnostics = Just [diagnostic] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType) + , _command = Nothing + , _data_ = Nothing + } + +mkChangeSigTitle :: Text -> Text -> Text +mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> "’ to: " <> actualType + +mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit +mkChangeSigEdit uri ss replacement = + let txtEdit = TextEdit (realSrcSpanToRange ss) replacement + changes = Just $ Map.singleton uri [txtEdit] + in WorkspaceEdit changes Nothing Nothing + +mkNewSignature :: Text -> Text -> Text +mkNewSignature declName actualType = declName <> " :: " <> actualType diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -0,0 +1,135 @@ +module Main where + +import Control.Monad (void) +import Data.Either (rights) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes) +import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +import System.FilePath ((<.>), ()) +import Test.Hls (CodeAction (..), Command, + GhcVersion (..), + PluginTestDescriptor, + Position (Position), + Range (Range), Session, + TestName, TestTree, + TextDocumentIdentifier, + assertFailure, def, + defaultTestRunner, + executeCodeAction, + getCodeActions, + goldenWithHaskellDoc, + knownBrokenForGhcVersions, + liftIO, + mkPluginTestDescriptor', + openDoc, runSessionWithServer, + testCase, testGroup, toEither, + type (|?), + waitForAllProgressDone, + waitForDiagnostics, (@?=)) +import Text.Regex.TDFA ((=~)) + +main :: IO () +main = defaultTestRunner test + +changeTypeSignaturePlugin :: PluginTestDescriptor () +changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature" + +test :: TestTree +test = testGroup "changeTypeSignature" [ + testRegexes + , codeActionTest "TExpectedActual" 4 11 + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Error Message in 9.2/9.4 does not provide enough info" $ codeActionTest "TRigidType" 4 14 + , codeActionTest "TRigidType2" 4 6 + , codeActionTest "TLocalBinding" 7 22 + , codeActionTest "TLocalBindingShadow1" 11 8 + , codeActionTest "TLocalBindingShadow2" 7 22 + , codeActionProperties "TErrorGivenPartialSignature" [(4, 13)] $ \actions -> liftIO $ length actions @?= 0 + ] + +testRegexes :: TestTree +testRegexes = testGroup "Regex Testing" [ + testRegexOne + , testRegexTwo + , testRegex921One + ] + +testRegexOne :: TestTree +testRegexOne = testGroup "Regex One" [ + regexTest "error1.txt" regex True + , regexTest "error2.txt" regex True + , regexTest "error3.txt" regex False + , regexTest "error4.txt" regex True + , regexTest "error5.txt" regex True + ] + where + regex = errorMessageRegexes !! 0 + +testRegexTwo :: TestTree +testRegexTwo = testGroup "Regex Two" [ + regexTest "error1.txt" regex False + , regexTest "error2.txt" regex False + , regexTest "error3.txt" regex True + , regexTest "error4.txt" regex False + , regexTest "error5.txt" regex False + ] + where + regex = errorMessageRegexes !! 1 + +-- test ghc-9.2 error message regex +testRegex921One :: TestTree +testRegex921One = testGroup "Regex One" [ + regexTest "ghc921-error1.txt" regex True + , regexTest "ghc921-error2.txt" regex True + , regexTest "ghc921-error3.txt" regex True + ] + where + regex = errorMessageRegexes !! 2 + +testDataDir :: FilePath +testDataDir = "plugins" "hls-change-type-signature-plugin" "test" "testdata" + +goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" + +codeActionTest :: FilePath -> Int -> Int -> TestTree +codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do + void waitForDiagnostics -- code actions are triggered from Diagnostics + void waitForAllProgressDone -- apparently some tests need this to get the CodeAction to show up + actions <- getCodeActions doc (pointRange line col) + foundActions <- findChangeTypeActions actions + liftIO $ length foundActions @?= 1 + executeCodeAction (head foundActions) + +codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree +codeActionProperties fp locs assertions = testCase fp $ do + runSessionWithServer def changeTypeSignaturePlugin testDataDir $ do + openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions + where + codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs + +findChangeTypeActions :: [Command |? CodeAction] -> Session [CodeAction] +findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither + where + isChangeTypeAction CodeAction{_kind} = case _kind of + Nothing -> False + Just kind -> case kind of + "quickfix.changeTypeSignature" -> True + _ -> False + + +regexTest :: FilePath -> Text -> Bool -> TestTree +regexTest fp regex shouldPass = testCase fp $ do + msg <- TIO.readFile (testDataDir fp) + case (msg =~ regex :: (Text, Text, Text, [Text]), shouldPass) of + ((_, _, _, [_, _, _, _]), True) -> pure () + ((_, _, _, [_, _, _, _]), False) -> assertFailure $ "Unexpected match: " <> fp <> " with " <> T.unpack regex + (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex + (_, False) -> pure () + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs @@ -0,0 +1,4 @@ +module ErrorGivenPartialSignature where + +partial :: Int -> Int +partial x = init x diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: [Int] -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: Int -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs @@ -0,0 +1,8 @@ +module TLocalBinding where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + test = forM + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs @@ -0,0 +1,8 @@ +module TLocalBinding where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = forM + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow1 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: [Double] -> (Double -> m0 b0) -> m0 [b0] +test = forM diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow1 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: [Double] -> Double +test = forM diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow2 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + test = forM + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow2 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = forM + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: [[Int]] -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: a -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.expected.hs @@ -0,0 +1,4 @@ +module TRigidType2 where + +test :: [Int] -> Int +test = head diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs @@ -0,0 +1,4 @@ +module TRigidType2 where + +test :: a -> Int +test = head diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘Int’ + with ‘Data.HashSet.Internal.HashSet Int’ + Expected type: Int -> Int + Actual type: Data.HashSet.Internal.HashSet Int -> Int + • In the expression: head . toList + In an equation for ‘test’: test = head . toList diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘b0 -> t0 a0 -> b0’ with ‘Int’ + Expected type: Int -> Int + Actual type: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 + • Probable cause: ‘foldl’ is applied to too few arguments + In the expression: foldl + In an equation for ‘test’: test = foldl diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt @@ -0,0 +1,10 @@ + • Couldn't match expected type ‘Int’ with actual type ‘[Int]’ + • In the expression: map (+ x) [1, 2, 3] + In an equation for ‘test’: + test x + = map (+ x) [1, 2, 3] + where + go = head . reverse + | +152 | test x = map (+ x) [1,2,3] + | ^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt @@ -0,0 +1,19 @@ + • Couldn't match type ‘a’ with ‘[[Int]]’ + ‘a’ is a rigid type variable bound by + the type signature for: + test :: forall a. Ord a => a -> Int + at src/Ide/Plugin/ChangeTypeSignature.hs:154:1-25 + Expected type: a -> Int + Actual type: [[Int]] -> Int + • In the expression: go . head . reverse + In an equation for ‘test’: + test + = go . head . reverse + where + go = head . reverse + • Relevant bindings include + test :: a -> Int + (bound at src/Ide/Plugin/ChangeTypeSignature.hs:155:1) + | +155 | test = go . head . reverse + | ^^^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt @@ -0,0 +1,15 @@ + • Couldn't match type ‘(a0 -> m0 b0) -> m0 (t0 b0)’ with ‘Int’ + Expected type: Int -> Int + Actual type: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + • Probable cause: ‘forM’ is applied to too few arguments + In the expression: forM + In an equation for ‘test’: test = forM + In an equation for ‘implicit’: + implicit + = return OpTEmpty + where + test :: Int -> Int + test = forM + | +82 | test = forM + | ^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘Data.Set.Internal.Set Int’ with ‘Int’ + Expected: Int -> [Int] + Actual: Data.Set.Internal.Set Int -> [Int] + • In the second argument of ‘(.)’, namely ‘toList’ + In the expression: head . toList + In an equation for ‘test’: test = head . toList + | +83 | test = head . toList + | ^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘b0 -> a0 -> b0’ with ‘Int’ + Expected: Int -> Int + Actual: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 + • Probable cause: ‘foldl’ is applied to too few arguments + In the expression: foldl + In an equation for ‘test’: test = foldl + | +83 | test = foldl + | diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘[Int]’ with ‘Int’ + Expected: Int -> [Int] + Actual: [Int] -> [Int] + • In the second argument of ‘(.)’, namely ‘reverse’ + In the expression: head . reverse + In an equation for ‘test’: test = head . reverse + | +84 | test = head . reverse + | diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml @@ -0,0 +1,12 @@ +cradle: + direct: + arguments: + - -i + - -i. + - TExpectedActual + - TRigidType + - TErrorGivenPartialSignature + - TLocalBinding + - TLocalBindingShadow1 + - TLocalBindingShadow2 + - -Wall diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -0,0 +1,25 @@ +module Ide.Plugin.Class (descriptor, Log(..)) where + +import Development.IDE (IdeState, Recorder, + WithPriority) +import Ide.Plugin.Class.CodeAction +import Ide.Plugin.Class.CodeLens +import Ide.Plugin.Class.Types +import Ide.Types +import Language.LSP.Protocol.Message +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides code actions and lenses for working with typeclasses") + { pluginCommands = commands plId + , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder) + <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens + <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve + } + +commands :: PluginId -> [PluginCommand IdeState] +commands plId + = [ PluginCommand codeActionCommandId + "add placeholders for minimal methods" (addMethodPlaceholders plId) + , PluginCommand typeLensCommandId + "add type signatures for instance methods" (codeLensCommandHandler plId) + ] diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.CodeAction where + +import Control.Lens hiding (List, use) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Extra +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe +import Data.Aeson hiding (Null) +import Data.Bifunctor (second) +import Data.Either.Extra (rights) +import Data.List +import Data.List.Extra (nubOrdOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (isNothing, listToMaybe, + mapMaybe) +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.Compile (sourceTypecheck) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (fromCurrentRange) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import Development.IDE.Spans.AtPoint (pointCommand) +import Ide.Plugin.Class.ExactPrint +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import qualified Ide.Plugin.Config +import Ide.Plugin.Error +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server + +addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams +addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do + caps <- lift getClientCapabilities + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state + $ useE GetParsedModule nfp + (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state + $ useE GhcSessionDeps nfp + (old, new) <- handleMaybeM (PluginInternalError "Unable to makeEditText") + $ liftIO $ runMaybeT + $ makeEditText pm df param + pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs + let edit = + if withSig + then mergeEdit (workspaceEdit caps old new) pragmaInsertion + else workspaceEdit caps old new + + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + + pure $ InR Null + where + toTextDocumentEdit edit = + TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] + + mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit + mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit + { _documentChanges = + (\x -> x ++ map (InL . toTextDocumentEdit) edits) + <$> _documentChanges + , .. + } + + workspaceEdit caps old new + = diffText caps (verTxtDocId, old) new IncludeDeletions + +-- | +-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is +-- sensitive to the format of diagnostic messages from GHC. +codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do + verTxtDocId <- lift $ getVersionedTextDoc docId + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags + pure $ InL actions + where + diags = context ^. L.diagnostics + + ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags + methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags + + mkActions + :: NormalizedFilePath + -> VersionedTextDocumentIdentifier + -> Diagnostic + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + mkActions docPath verTxtDocId diag = do + (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state + $ useWithStaleE GetHieAst docPath + instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $ + fromCurrentRange pmap range ^? _Just . L.start + & fmap (L.character -~ 1) + ident <- findClassIdentifier ast instancePosition + cls <- findClassFromIdentifier docPath ident + InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state + $ useE GetInstanceBindTypeSigs docPath + (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath + (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath + implemented <- findImplementedMethods ast instancePosition + logWith recorder Info (LogImplementedMethods cls implemented) + pure + $ concatMap mkAction + $ nubOrdOn snd + $ filter ((/=) mempty . snd) + $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented))) + $ mkMethodGroups hsc gblEnv range sigs cls + where + range = diag ^. L.range + + mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup] + mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods] + where + minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls + allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs) + + mkAction :: MethodGroup -> [Command |? CodeAction] + mkAction (name, methods) + = [ mkCodeAction title + $ mkLspCommand plId codeActionCommandId title + (Just $ mkCmdParams methods False) + , mkCodeAction titleWithSig + $ mkLspCommand plId codeActionCommandId titleWithSig + (Just $ mkCmdParams methods True) + ] + where + title = "Add placeholders for " <> name + titleWithSig = title <> " with signature(s)" + + mkCmdParams :: [(T.Text, T.Text)] -> Bool -> [Value] + mkCmdParams methodGroup withSig = + [toJSON (AddMinimalMethodsParams verTxtDocId range methodGroup withSig)] + + mkCodeAction title cmd + = InR + $ CodeAction + title + (Just CodeActionKind_QuickFix) + (Just []) + Nothing + Nothing + Nothing + (Just cmd) + Nothing + + findClassIdentifier hf instancePosition = + handleMaybe (PluginInternalError "No Identifier found") + $ listToMaybe + $ mapMaybe listToMaybe + $ pointCommand hf instancePosition + ( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds) + <=< nodeChildren + ) + + findImplementedMethods + :: HieASTs a + -> Position + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] + findImplementedMethods asts instancePosition = do + pure + $ concat + $ pointCommand asts instancePosition + $ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers + + -- | Recurses through the given AST to find identifiers which are + -- 'InstanceValBind's. + findInstanceValBindIdentifiers :: HieAST a -> [Identifier] + findInstanceValBindIdentifiers ast = + let valBindIds = Map.keys + . Map.filter (any isInstanceValBind . identInfo) + $ getNodeIds ast + in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast) + + findClassFromIdentifier docPath (Right name) = do + (hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state + $ useWithStaleE GhcSessionDeps docPath + (tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state + $ useWithStaleE TypeCheck docPath + handleMaybeM (PluginInternalError "initTcWithGbl failed") + . liftIO + . fmap snd + . initTcWithGbl hscenv thisMod ghostSpan $ do + tcthing <- tcLookup name + case tcthing of + AGlobal (AConLike (RealDataCon con)) + | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls + _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" + findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier") + +-- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc +isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool +isClassNodeIdentifier (Right i) ident | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident +isClassNodeIdentifier _ _ = False + +isClassMethodWarning :: T.Text -> Bool +isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" + +isInstanceValBind :: ContextInfo -> Bool +isInstanceValBind (ValBind InstanceBind _ _) = True +isInstanceValBind _ = False + +type MethodSignature = T.Text +type MethodName = T.Text +type MethodDefinition = (MethodName, MethodSignature) +type MethodGroup = (T.Text, [MethodDefinition]) + +makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition +makeMethodDefinition hsc gblEnv sig = (name, signature) + where + name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig)) + signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig)) + +makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition] +makeMethodDefinitions hsc gblEnv range sigs = + [ makeMethodDefinition hsc gblEnv sig + | sig <- sigs + , inRange range (getSrcSpan $ bindName sig) + ] + +signatureToName :: InstanceBindTypeSig -> T.Text +signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig)) + +-- Return [groupName text, [(methodName text, signature text)]] +minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup] +minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef + where + makeMethodGroup methodDefinitions = + let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions + in (name, methodDefinitions) + + go (Var mn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs + go (Or ms) = concatMap (go . unLoc) ms + go (And ms) = foldr (liftA2 (<>) . go . unLoc) [[]] ms + go (Parens m) = go (unLoc m) + diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.Class.CodeLens where + +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson hiding (Null) +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe (mapMaybe, maybeToList) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.GHC.Compat +import Development.IDE.Spans.Pragmas (getFirstPragma, + insertNewPragma) +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import Ide.Plugin.Error +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (sendRequest) + +-- The code lens method is only responsible for providing the ranges of the code +-- lenses matched to a unique id +codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens +codeLens state _plId clp = do + nfp <- getNormalizedFilePathE $ clp ^. L.textDocument . L.uri + (InstanceBindLensResult (InstanceBindLens{lensRange}), pm) + <- runActionE "classplugin.GetInstanceBindLens" state + -- Using stale results means that we can almost always return a + -- value. In practice this means the lenses don't 'flicker' + $ useWithStaleE GetInstanceBindLens nfp + pure $ InL $ mapMaybe (toCodeLens pm) lensRange + where toCodeLens pm (range, int) = + let newRange = toCurrentRange pm range + in (\r -> CodeLens r Nothing (Just $ toJSON int)) <$> newRange + +-- The code lens resolve method matches a title to each unique id +codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve +codeLensResolve state plId cl uri uniqueID = do + nfp <- getNormalizedFilePathE uri + (InstanceBindLensResult (InstanceBindLens{lensDetails}), pm) + <- runActionE "classplugin.GetInstanceBindLens" state + $ useWithStaleE GetInstanceBindLens nfp + (tmrTypechecked -> gblEnv, _) <- runActionE "classplugin.codeAction.TypeCheck" state $ useWithStaleE TypeCheck nfp + (hscEnv -> hsc, _) <- runActionE "classplugin.codeAction.GhcSession" state $ useWithStaleE GhcSession nfp + (range, name, typ) <- handleMaybe PluginStaleResolve + $ IntMap.lookup uniqueID lensDetails + let title = prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ) + edit <- handleMaybe (PluginInvalidUserState "toCurrentRange") $ makeEdit range title pm + let command = mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri edit]) + pure $ cl & L.command ?~ command + where + makeEdit :: Range -> T.Text -> PositionMapping -> Maybe TextEdit + makeEdit range bind mp = + let startPos = range ^. L.start + insertChar = startPos ^. L.character + insertRange = Range startPos startPos + in case toCurrentRange mp insertRange of + Just rg -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ") + Nothing -> Nothing + +-- Finally the command actually generates and applies the workspace edit for the +-- specified unique id. +codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand +codeLensCommandHandler plId state _ InstanceBindLensCommand{commandUri, commandEdit} = do + nfp <- getNormalizedFilePathE commandUri + (InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _) + <- runActionE "classplugin.GetInstanceBindLens" state + $ useWithStaleE GetInstanceBindLens nfp + -- We are only interested in the pragma information if the user does not + -- have the InstanceSigs extension enabled + mbPragma <- if InstanceSigs `elem` lensEnabledExtensions + then pure Nothing + else Just <$> getFirstPragma plId state nfp + let -- By mapping over our Maybe NextPragmaInfo value, we only compute this + -- edit if we actually need to. + pragmaInsertion = + maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma + wEdit = workspaceEdit pragmaInsertion + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ()) + pure $ InR Null + where + workspaceEdit pragmaInsertion= + WorkspaceEdit + (pure [(commandUri, commandEdit : pragmaInsertion)]) + Nothing + Nothing + + + + diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Class.ExactPrint where + +import Control.Monad.Trans.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers + +import Data.Either.Extra (eitherToMaybe) +import Data.Functor.Identity (Identity) +import GHC.Parser.Annotation +import Language.LSP.Protocol.Types (Range) + +makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) +makeEditText pm df AddMinimalMethodsParams{..} = do + mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = makeDeltaAst $ pm_parsed_source pm + old = T.pack $ exactPrint ps + (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) + new = T.pack $ exactPrint ps' + pure (old, new) + +makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (LHsDecl GhcPs, LHsDecl GhcPs) +makeMethodDecl df (mName, sig) = do + name <- eitherToMaybe $ parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" + sig' <- eitherToMaybe $ parseDecl df (T.unpack sig) $ T.unpack sig + pure (name, sig') + +#if MIN_VERSION_ghc(9,5,0) +addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located (HsModule GhcPs)) +#else +addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule) +#endif +addMethodDecls ps mDecls range withSig + | withSig = go (concatMap (\(decl, sig) -> [sig, decl]) mDecls) + | otherwise = go (map fst mDecls) + where + go inserting = do + allDecls <- hsDecls ps + case break (inRange range . getLoc) allDecls of + (before, L l inst : after) -> replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ after)) + (before, []) -> replaceDecls ps before + + -- Add `where` keyword for `instance X where` if `where` is missing. + -- + -- The `where` in ghc-9.2 is now stored in the instance declaration + -- directly. More precisely, giving an `HsDecl GhcPs`, we have: + -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), + -- here `AnnEpAnn` keeps the track of Anns. + -- + -- See the link for the original definition: + -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl + addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = + case cid_ext of + (EpAnn entry anns comments, key) -> + InstD xInstD (ClsInstD ext decl { + cid_ext = (EpAnn + entry + (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) + comments + , key) + }) + _ -> instd + addWhere decl = decl + + newLine (L l e) = + let dp = deltaPos 1 defaultIndent + in L (noAnnSrcSpanDP (getLoc l) dp <> l) e + diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.Types where + +import Control.DeepSeq (rwhnf) +import Control.Monad.Extra (mapMaybeM, whenMaybe) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.Aeson +import qualified Data.IntMap as IntMap +import Data.List.Extra (firstJust) +import Data.Maybe (catMaybes, mapMaybe, + maybeToList) +import qualified Data.Text as T +import Data.Unique (hashUnique, newUnique) +import Development.IDE +import Development.IDE.Core.PluginUtils (useMT) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) +import Development.IDE.GHC.Compat.Util (bagToList) +import Development.IDE.Graph.Classes +import GHC.Generics +import Ide.Plugin.Class.Utils +import Ide.Types +import Language.LSP.Protocol.Types (TextEdit, + VersionedTextDocumentIdentifier) + +typeLensCommandId :: CommandId +typeLensCommandId = "classplugin.typelens" + +codeActionCommandId :: CommandId +codeActionCommandId = "classplugin.codeaction" + +-- | Default indent size for inserting +defaultIndent :: Int +defaultIndent = 2 + +data AddMinimalMethodsParams = AddMinimalMethodsParams + { verTxtDocId :: VersionedTextDocumentIdentifier + , range :: Range + , methodGroup :: [(T.Text, T.Text)] + -- ^ (name text, signature text) + , withSig :: Bool + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- |The InstanceBindTypeSigs Rule collects the instance bindings type +-- signatures (both name and type). It is used by both the code actions and the +-- code lenses +data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +data InstanceBindTypeSig = InstanceBindTypeSig + { bindName :: Name + , bindType :: Type + } + +newtype InstanceBindTypeSigsResult = + InstanceBindTypeSigsResult [InstanceBindTypeSig] + +instance Show InstanceBindTypeSigsResult where + show _ = "" + +instance NFData InstanceBindTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult + +-- |The necessary data to execute our code lens +data InstanceBindLensCommand = InstanceBindLensCommand + { -- |The URI needed to run actions in the command + commandUri :: Uri + -- |The specific TextEdit we want to apply. This does not include the + -- pragma edit which is computed in the command + , commandEdit :: TextEdit } + deriving (Generic, FromJSON, ToJSON) + +-- | The InstanceBindLens rule is specifically for code lenses. It relies on +-- the InstanceBindTypeSigs rule, filters out irrelevant matches and signatures +-- that can't be matched to a source span. It provides all the signatures linked +-- to a unique ID to aid in resolving. It also provides a list of enabled +-- extensions. +data GetInstanceBindLens = GetInstanceBindLens + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +data InstanceBindLens = InstanceBindLens + { -- |What we need to provide the code lens. The range linked with + -- a unique ID that will allow us to resolve the rest of the data later + lensRange :: [(Range, Int)] + -- |Provides the necessary data to allow us to display the + -- title of the lens and compute a TextEdit for it. + , lensDetails :: IntMap.IntMap (Range, Name, Type) + -- |Provides currently enabled extensions, allowing us to conditionally + -- insert needed extensions. + , lensEnabledExtensions :: [Extension] + } + +newtype InstanceBindLensResult = + InstanceBindLensResult InstanceBindLens + +instance Show InstanceBindLensResult where + show _ = "" + +instance NFData InstanceBindLensResult where + rnf = rwhnf + +type instance RuleResult GetInstanceBindLens = InstanceBindLensResult + +data Log + = LogImplementedMethods Class [T.Text] + | LogShake Shake.Log + +instance Pretty Log where + pretty = \case + LogImplementedMethods cls methods -> + pretty ("Detected implemented methods for class" :: String) + <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name + <+> pretty methods + LogShake log -> pretty log + +data BindInfo = BindInfo + { bindSpan :: SrcSpan + -- ^ SrcSpan of the whole binding + , bindNameSpan :: SrcSpan + -- ^ SrcSpan of the binding name + } + +getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () +getInstanceBindLensRule recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do + tmr@(tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp + (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp + + let -- declared instance methods without signatures + bindInfos = [ bind + | instds <- map group_instds tycls -- class instance decls + , instd <- instds + , inst <- maybeToList $ getClsInstD (unLoc instd) + , bind <- getBindSpanWithoutSig inst + ] + targetSigs = matchBind bindInfos allBinds + rangeIntNameType <- liftIO $ mapMaybeM getRangeWithSig targetSigs + let lensRange = (\(range, int, _, _) -> (range, int)) <$> rangeIntNameType + lensDetails = IntMap.fromList $ (\(range, int, name, typ) -> (int, (range, name, typ))) <$> rangeIntNameType + lensEnabledExtensions = getExtensions $ tmrParsed tmr + pure $ InstanceBindLensResult $ InstanceBindLens{..} + where + -- Match Binds with their signatures + -- We try to give every `InstanceBindTypeSig` a `SrcSpan`, + -- hence we can display signatures for `InstanceBindTypeSig` with span later. + matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)] + matchBind existedBinds allBindWithSigs = + [firstJust (go bindSig) existedBinds | bindSig <- allBindWithSigs] + where + go :: InstanceBindTypeSig -> BindInfo -> Maybe (InstanceBindTypeSig, SrcSpan) + go bindSig bind = do + range <- (srcSpanToRange . bindNameSpan) bind + if inRange range (getSrcSpan $ bindName bindSig) + then Just (bindSig, bindSpan bind) + else Nothing + + getClsInstD (ClsInstD _ d) = Just d + getClsInstD _ = Nothing + + getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames + getSigName _ = Nothing + + getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo] + getBindSpanWithoutSig ClsInstDecl{..} = + let bindNames = mapMaybe go (bagToList cid_binds) + go (L l bind) = case bind of + FunBind{..} + -- `Generated` tagged for Template Haskell, + -- here we filter out nonsense generated bindings + -- that are nonsense for displaying code lenses. + -- + -- See https://github.com/haskell/haskell-language-server/issues/3319 + | not $ isGenerated (groupOrigin fun_matches) + -> Just $ L l fun_id + _ -> Nothing + -- Existed signatures' name + sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs + toBindInfo (L l (L l' _)) = BindInfo + (locA l) -- bindSpan + (locA l') -- bindNameSpan + in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames + + -- Get bind definition range with its rendered signature text + getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan) -> IO (Maybe (Range, Int, Name, Type)) + getRangeWithSig (Just (bind, span)) = runMaybeT $ do + range <- MaybeT . pure $ srcSpanToRange span + uniqueID <- liftIO $ hashUnique <$> newUnique + pure (range, uniqueID, bindName bind, bindType bind) + getRangeWithSig Nothing = pure Nothing + + +getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules () +getInstanceBindTypeSigsRule recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> runMaybeT $ do + (tmrTypechecked -> gblEnv ) <- useMT TypeCheck nfp + (hscEnv -> hsc) <- useMT GhcSession nfp + let binds = collectHsBindsBinders $ tcg_binds gblEnv + (_, maybe [] catMaybes -> instanceBinds) <- liftIO $ + initTcWithGbl hsc gblEnv ghostSpan +#if MIN_VERSION_ghc(9,7,0) + $ liftZonkM +#endif + $ traverse bindToSig binds + pure $ InstanceBindTypeSigsResult instanceBinds + where + bindToSig id = do + let name = idName id + whenMaybe (isBindingName name) $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ InstanceBindTypeSig name ty diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.Utils where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except +import Data.Char (isAlpha) +import Data.List (isPrefixOf) +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PluginUtils +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import Development.IDE.Spans.Pragmas (getNextPragmaInfo, + insertNewPragma) +import Ide.Plugin.Error +import Ide.PluginUtils +import Language.LSP.Protocol.Types + +-- | All instance bindings are started with `$c` +bindingPrefix :: IsString s => s +bindingPrefix = "$c" + +isBindingName :: Name -> Bool +isBindingName name = isPrefixOf bindingPrefix $ occNameString $ nameOccName name + +-- | Check if some `HasSrcSpan` value in the given range +inRange :: Range -> SrcSpan -> Bool +inRange range s = maybe False (subRange range) (srcSpanToRange s) + +ghostSpan :: RealSrcSpan +ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 + +-- | "$cname" ==> "name" +prettyBindingNameString :: T.Text -> T.Text +prettyBindingNameString name + | T.isPrefixOf bindingPrefix name = + toMethodName $ T.drop (T.length bindingPrefix) name + | otherwise = name + +showDoc :: HscEnv -> TcGblEnv -> Type -> String +showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty) + where rdrEnv gblEnv = tcg_rdr_env gblEnv + +-- | Paren the name for pretty display if necessary +toMethodName :: T.Text -> T.Text +toMethodName n + | Just (h, _) <- T.uncons n + , not (isAlpha h || h == '_') + = "(" <> n <> ")" + | otherwise + = n + +-- | Here we use `useWithStale` to compute, Using stale results means that we can almost always return a value. +-- In practice this means the lenses don't 'flicker'. +-- This function is also used in code actions, but it doesn't matter because our actions only work +-- if the module parsed success. +insertPragmaIfNotPresent :: (MonadIO m) + => IdeState + -> NormalizedFilePath + -> Extension + -> ExceptT PluginError m [TextEdit] +insertPragmaIfNotPresent state nfp pragma = do + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state + $ useWithStaleE GhcSession nfp + (_, fileContents) <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state + $ getFileContents nfp + (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state + $ useWithStaleE GetParsedModuleWithComments nfp + let exts = getExtensions pm + info = getNextPragmaInfo sessionDynFlags fileContents + pure [insertNewPragma info pragma | pragma `notElem` exts] diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/Main.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Exception (catch) +import Control.Lens (Prism', prism', view, (^.), + (^..), (^?)) +import Control.Monad (void) +import Data.Foldable (find) +import Data.Maybe +import Data.Row ((.==)) +import qualified Data.Text as T +import qualified Ide.Plugin.Class as Class +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +classPlugin :: PluginTestDescriptor Class.Log +classPlugin = mkPluginTestDescriptor Class.descriptor "class" + +tests :: TestTree +tests = testGroup + "class" + [ codeActionTests + , codeLensTests + ] + +codeActionTests :: TestTree +codeActionTests = testGroup + "code actions" + [ expectCodeActionsAvailable "Produces addMinimalMethodPlaceholders code actions for one instance" "T1" + [ "Add placeholders for '=='" + , "Add placeholders for '==' with signature(s)" + , "Add placeholders for '/='" + , "Add placeholders for '/=' with signature(s)" + , "Add placeholders for all missing methods" + , "Add placeholders for all missing methods with signature(s)" + ] + , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ + getActionByTitle "Add placeholders for '=='" + , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ + getActionByTitle "Add placeholders for '/='" + , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ + getActionByTitle "Add placeholders for all missing methods" + , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ + getActionByTitle "Add placeholders for 'fmap'" + , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ + getActionByTitle "Add placeholders for 'f','g'" + , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ + getActionByTitle "Add placeholders for 'g','h'" + , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ + getActionByTitle "Add placeholders for '_f'" + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ + getActionByTitle "Add placeholders for '=='" + , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ + getActionByTitle "Add placeholders for 'g'" + , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ + getActionByTitle "Add placeholders for 'g','h'" + , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ + goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ + getActionByTitle "Add placeholders for 'pure','<*>' with signature(s)" + , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" [] + , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired" + [ "Add placeholders for 'f','g'" + , "Add placeholders for 'f','g' with signature(s)" + ] + , testCase "Update text document version" $ runSessionWithServer def classPlugin testDataDir $ do + doc <- createDoc "Version.hs" "haskell" "module Version where" + ver1 <- (^. L.version) <$> getVersionedDoc doc + liftIO $ ver1 @?= 0 + + -- Change the doc to ensure the version is not 0 + changeDoc doc + [ TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module Version where", "data A a = A a", "instance Functor A where"] + ] + ver2 <- (^. L.version) <$> getVersionedDoc doc + _ <- waitForDiagnostics + liftIO $ ver2 @?= 1 + + -- Execute the action and see what the version is + action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc + executeCodeAction action + _ <- waitForDiagnostics + ver3 <- (^. L.version) <$> getVersionedDoc doc + liftIO $ ver3 @?= 2 + pure mempty + ] + +codeLensTests :: TestTree +codeLensTests = testGroup + "code lens" + [ testCase "Has code lens" $ do + runSessionWithServer def classPlugin testDataDir $ do + doc <- openDoc "CodeLensSimple.hs" "haskell" + lens <- getAndResolveCodeLenses doc + let titles = map (^. L.title) $ mapMaybe (^. L.command) lens + liftIO $ titles @?= + [ "(==) :: B -> B -> Bool" + , "(==) :: A -> A -> Bool" + ] + , testCase "No lens for TH" $ do + runSessionWithServer def classPlugin testDataDir $ do + doc <- openDoc "TH.hs" "haskell" + lens <- getAndResolveCodeLenses doc + liftIO $ length lens @?= 0 + , testCase "Do not construct error action!, Ticket3942one" $ do + runSessionWithServer def classPlugin testDataDir $ do + doc <- openDoc "Ticket3942one.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + lens <- getAllCodeActions doc + -- should switch to `liftIO $ length lens @?= 2, when Ticket3942 is entirely fixed` + -- current fix is just to make sure the code does not throw an exception that would mess up + -- the client UI. + liftIO $ length lens > 0 @?= True + `catch` \(e :: SessionException) -> do + liftIO $ assertFailure $ "classPluginTestError: "++ show e + , goldenCodeLens "Apply code lens" "CodeLensSimple" 1 + , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 + , goldenCodeLens "Apply code lens on the same line" "Inline" 0 + , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0 + , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ + goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 + , goldenCodeLens "Qualified name" "Qualified" 0 + , goldenCodeLens "Type family" "TypeFamily" 0 + , testCase "keep stale lens" $ do + runSessionWithServer def classPlugin testDataDir $ do + doc <- openDoc "Stale.hs" "haskell" + oldLens <- getAndResolveCodeLenses doc + let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_` + _ <- applyEdit doc edit + newLens <- getAndResolveCodeLenses doc + liftIO $ (view L.command <$> newLens ) @?= (view L.command <$> oldLens) + ] + +_CACodeAction :: Prism' (Command |? CodeAction) CodeAction +_CACodeAction = prism' InR $ \case + InR action -> Just action + _ -> Nothing + +goldenCodeLens :: TestName -> FilePath -> Int -> TestTree +goldenCodeLens title path idx = + goldenWithHaskellDoc def classPlugin title testDataDir path "expected" "hs" $ \doc -> do + lens <- getAndResolveCodeLenses doc + executeCommand $ fromJust $ (lens !! idx) ^. L.command + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + +goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree +goldenWithClass title path desc findAction = + goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc + action <- findAction actions + executeCodeAction action + void $ skipManyTill anyMessage (getDocumentEdit doc) + +getActionByTitle :: T.Text -> [CodeAction] -> Session CodeAction +getActionByTitle title actions = case find (\a -> a ^. L.title == title) actions of + Just a -> pure a + Nothing -> liftIO $ assertFailure $ "Action " <> show title <> " not found in " <> show [a ^. L.title | a <- actions] + +expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree +expectCodeActionsAvailable title path actionTitles = + testCase title $ do + runSessionWithServer def classPlugin testDataDir $ do + doc <- openDoc (path <.> "hs") "haskell" + _ <- waitForDiagnosticsFrom doc + caResults <- getAllCodeActions doc + liftIO $ map (^? _CACodeAction . L.title) caResults + @?= expectedActions + where + expectedActions = Just <$> actionTitles + +testDataDir :: FilePath +testDataDir = "plugins" "hls-class-plugin" "test" "testdata" diff --git a/plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs b/plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs @@ -0,0 +1,9 @@ +module AllMethodsRequired where + +class Test a where + f :: a + g :: a + {-# MINIMAL f,g #-} + +instance Test [a] where + diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensSimple.expected.hs b/plugins/hls-class-plugin/test/testdata/CodeLensSimple.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensSimple.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensSimple where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ + +data B +instance Eq B where + (==)= _ diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensSimple.hs b/plugins/hls-class-plugin/test/testdata/CodeLensSimple.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensSimple.hs @@ -0,0 +1,9 @@ +module CodeLensSimple where + +data A +instance Eq A where + (==) = _ + +data B +instance Eq B where + (==)= _ diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.expected.hs b/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021 #-} +module CodeLensWithGHC2021 where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.hs b/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensWithGHC2021.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GHC2021 #-} +module CodeLensWithGHC2021 where + +data A +instance Eq A where + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.expected.hs b/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensWithPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.hs b/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/CodeLensWithPragma.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensWithPragma where + +data A +instance Eq A where + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/Inline.expected.hs b/plugins/hls-class-plugin/test/testdata/Inline.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Inline.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE InstanceSigs #-} +module Inline where + +data A +instance Eq A where (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/Inline.hs b/plugins/hls-class-plugin/test/testdata/Inline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Inline.hs @@ -0,0 +1,4 @@ +module Inline where + +data A +instance Eq A where (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.expected.hs b/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertPragmaOnce where + +data A aaa +instance Applicative A where + pure :: a -> A a + pure = _ + (<*>) :: A (a -> b) -> A a -> A b + (<*>) = _ diff --git a/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.hs b/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertPragmaOnce.hs @@ -0,0 +1,4 @@ +module InsertPragmaOnce where + +data A aaa +instance Applicative A diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.expected.hs b/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021#-} +module InsertWithGHC2021Enabled where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.hs b/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithGHC2021Enabled.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GHC2021#-} +module InsertWithGHC2021Enabled where + +data A +instance Eq A diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithPragma.expected.hs b/plugins/hls-class-plugin/test/testdata/InsertWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithPragma.hs b/plugins/hls-class-plugin/test/testdata/InsertWithPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithPragma.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithPragma where + +data A +instance Eq A diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.expected.hs b/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithoutPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.hs b/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/InsertWithoutPragma.hs @@ -0,0 +1,4 @@ +module InsertWithoutPragma where + +data A +instance Eq A diff --git a/plugins/hls-class-plugin/test/testdata/LocalClassDefine.expected.hs b/plugins/hls-class-plugin/test/testdata/LocalClassDefine.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/LocalClassDefine.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE InstanceSigs #-} +module LocalClassDefine where + +data A +class F a where + f :: a -> Int + +instance F A where + f :: A -> Int + f = _ diff --git a/plugins/hls-class-plugin/test/testdata/LocalClassDefine.hs b/plugins/hls-class-plugin/test/testdata/LocalClassDefine.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/LocalClassDefine.hs @@ -0,0 +1,8 @@ +module LocalClassDefine where + +data A +class F a where + f :: a -> Int + +instance F A where + f = _ diff --git a/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs b/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs @@ -0,0 +1,6 @@ +module MinimalDefinitionMeet where + +data X = X + +instance Eq X where + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/Qualified.expected.hs b/plugins/hls-class-plugin/test/testdata/Qualified.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Qualified.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE InstanceSigs #-} +module Qualified where +import qualified QualifiedA + +class F a where + f :: a + +instance F QualifiedA.A where + f :: QualifiedA.A + f = undefined diff --git a/plugins/hls-class-plugin/test/testdata/Qualified.hs b/plugins/hls-class-plugin/test/testdata/Qualified.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Qualified.hs @@ -0,0 +1,8 @@ +module Qualified where +import qualified QualifiedA + +class F a where + f :: a + +instance F QualifiedA.A where + f = undefined diff --git a/plugins/hls-class-plugin/test/testdata/QualifiedA.hs b/plugins/hls-class-plugin/test/testdata/QualifiedA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/QualifiedA.hs @@ -0,0 +1,3 @@ +module QualifiedA where + +data A diff --git a/plugins/hls-class-plugin/test/testdata/Stale.hs b/plugins/hls-class-plugin/test/testdata/Stale.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Stale.hs @@ -0,0 +1,5 @@ +module Stale where + +data A a +instance Functor A where + fmap = _ diff --git a/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs b/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs @@ -0,0 +1,7 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ + (/=) = _ diff --git a/plugins/hls-class-plugin/test/testdata/T1.eq.expected.hs b/plugins/hls-class-plugin/test/testdata/T1.eq.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T1.eq.expected.hs @@ -0,0 +1,6 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/T1.hs b/plugins/hls-class-plugin/test/testdata/T1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T1.hs @@ -0,0 +1,5 @@ +module T1 where + +data X = X + +instance Eq X where diff --git a/plugins/hls-class-plugin/test/testdata/T1.ne.expected.hs b/plugins/hls-class-plugin/test/testdata/T1.ne.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T1.ne.expected.hs @@ -0,0 +1,6 @@ +module T1 where + +data X = X + +instance Eq X where + (/=) = _ diff --git a/plugins/hls-class-plugin/test/testdata/T2.fmap.expected.hs b/plugins/hls-class-plugin/test/testdata/T2.fmap.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T2.fmap.expected.hs @@ -0,0 +1,13 @@ +module T2 where + +data X a + = A a + | B + +instance + (Eq a) => Eq (X a) + where + +instance + Functor X where + fmap = _ diff --git a/plugins/hls-class-plugin/test/testdata/T2.hs b/plugins/hls-class-plugin/test/testdata/T2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T2.hs @@ -0,0 +1,12 @@ +module T2 where + +data X a + = A a + | B + +instance + (Eq a) => Eq (X a) + where + +instance + Functor X diff --git a/plugins/hls-class-plugin/test/testdata/T3.1.expected.hs b/plugins/hls-class-plugin/test/testdata/T3.1.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T3.1.expected.hs @@ -0,0 +1,13 @@ +module T3 where + +class Test a where + f :: a + f = h + g :: a + h :: a + h = f + {-# MINIMAL f, g | g, h #-} + +instance Test [a] where + f = _ + g = _ diff --git a/plugins/hls-class-plugin/test/testdata/T3.2.expected.hs b/plugins/hls-class-plugin/test/testdata/T3.2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T3.2.expected.hs @@ -0,0 +1,13 @@ +module T3 where + +class Test a where + f :: a + f = h + g :: a + h :: a + h = f + {-# MINIMAL f, g | g, h #-} + +instance Test [a] where + g = _ + h = _ diff --git a/plugins/hls-class-plugin/test/testdata/T3.hs b/plugins/hls-class-plugin/test/testdata/T3.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T3.hs @@ -0,0 +1,11 @@ +module T3 where + +class Test a where + f :: a + f = h + g :: a + h :: a + h = f + {-# MINIMAL f, g | g, h #-} + +instance Test [a] where diff --git a/plugins/hls-class-plugin/test/testdata/T4.expected.hs b/plugins/hls-class-plugin/test/testdata/T4.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T4.expected.hs @@ -0,0 +1,8 @@ +module T4 where + +class Test a where + _f :: a + {-# MINIMAL _f #-} + +instance Test Int where + _f = _ diff --git a/plugins/hls-class-plugin/test/testdata/T4.hs b/plugins/hls-class-plugin/test/testdata/T4.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T4.hs @@ -0,0 +1,7 @@ +module T4 where + +class Test a where + _f :: a + {-# MINIMAL _f #-} + +instance Test Int where diff --git a/plugins/hls-class-plugin/test/testdata/T5.expected.hs b/plugins/hls-class-plugin/test/testdata/T5.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.expected.hs @@ -0,0 +1,8 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ + +x = () diff --git a/plugins/hls-class-plugin/test/testdata/T5.hs b/plugins/hls-class-plugin/test/testdata/T5.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.hs @@ -0,0 +1,7 @@ +module T1 where + +data X = X + +instance Eq X where + +x = () diff --git a/plugins/hls-class-plugin/test/testdata/T6.1.expected.hs b/plugins/hls-class-plugin/test/testdata/T6.1.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T6.1.expected.hs @@ -0,0 +1,22 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined + g = _ diff --git a/plugins/hls-class-plugin/test/testdata/T6.2.expected.hs b/plugins/hls-class-plugin/test/testdata/T6.2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T6.2.expected.hs @@ -0,0 +1,23 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined + g = _ + h = _ diff --git a/plugins/hls-class-plugin/test/testdata/T6.expected.hs b/plugins/hls-class-plugin/test/testdata/T6.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T6.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021#-} +module T6 where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/T6.hs b/plugins/hls-class-plugin/test/testdata/T6.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T6.hs @@ -0,0 +1,21 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined diff --git a/plugins/hls-class-plugin/test/testdata/TH.hs b/plugins/hls-class-plugin/test/testdata/TH.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/TH.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TH where + +import THDef + +gen ''Bool True +gen ''Char 'a' diff --git a/plugins/hls-class-plugin/test/testdata/THDef.hs b/plugins/hls-class-plugin/test/testdata/THDef.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/THDef.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +module THDef where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +class F a where + f :: a + +gen :: Lift t => Name -> t -> Q [Dec] +gen ty v = [d| instance F $(conT ty) where f = v |] diff --git a/plugins/hls-class-plugin/test/testdata/Ticket3942one.hs b/plugins/hls-class-plugin/test/testdata/Ticket3942one.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Ticket3942one.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Ticket3942one where + +class C a where + foo :: a -> Int + +newtype Foo = MkFoo Int deriving (C) +instance Show Foo where + + +main :: IO () +main = return () diff --git a/plugins/hls-class-plugin/test/testdata/TypeFamily.expected.hs b/plugins/hls-class-plugin/test/testdata/TypeFamily.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/TypeFamily.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} +module TypeFamily where + +class F a where + type Elem a + f :: Elem a -> a + +instance Eq a => F [a] where + f :: Eq a => Elem [a] -> [a] + f = _ diff --git a/plugins/hls-class-plugin/test/testdata/TypeFamily.hs b/plugins/hls-class-plugin/test/testdata/TypeFamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/TypeFamily.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamily where + +class F a where + type Elem a + f :: Elem a -> a + +instance Eq a => F [a] where + f = _ diff --git a/plugins/hls-class-plugin/test/testdata/hie.yaml b/plugins/hls-class-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [-XHaskell2010, QualifiedA, THDef] diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Ide.Plugin.CodeRange ( + descriptor + , Log + + -- * Internal + , findPosition + , findFoldingRanges + , createFoldingRange + ) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + maybeToExceptT) +import Data.List.Extra (drop1) +import Data.Maybe (fromMaybe) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Development.IDE (Action, + IdeState (shakeExtras), + Range (Range), Recorder, + WithPriority, + cmapWithPrio) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (PositionMapping, + toCurrentRange) +import Ide.Logger (Pretty (..)) +import Ide.Plugin.CodeRange.Rules (CodeRange (..), + GetCodeRange (..), + codeRangeRule, crkToFrk) +import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) +import Ide.Plugin.Error +import Ide.PluginUtils (positionInRange) +import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message (Method (Method_TextDocumentFoldingRange, Method_TextDocumentSelectionRange), + SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) +import Language.LSP.Protocol.Types (FoldingRange (..), + FoldingRangeParams (..), + NormalizedFilePath, Null, + Position (..), + Range (_start), + SelectionRange (..), + SelectionRangeParams (..), + TextDocumentIdentifier (TextDocumentIdentifier), + Uri, type (|?) (InL)) +import Prelude hiding (log, span) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides selection and folding ranges for Haskell") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentSelectionRange (selectionRangeHandler recorder) + <> mkPluginHandler SMethod_TextDocumentFoldingRange (foldingRangeHandler recorder) + , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) + } + +newtype Log = LogRules Rules.Log + +instance Pretty Log where + pretty (LogRules codeRangeLog) = pretty codeRangeLog + + +foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange +foldingRangeHandler _ ide _ FoldingRangeParams{..} = + do + filePath <- getNormalizedFilePathE uri + foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath + pure . InL $ foldingRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + +getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] +getFoldingRanges file = do + codeRange <- useE GetCodeRange file + pure $ findFoldingRanges codeRange + +selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange +selectionRangeHandler _ ide _ SelectionRangeParams{..} = do + do + filePath <- getNormalizedFilePathE uri + mapExceptT liftIO $ getSelectionRanges ide filePath positions + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + + positions :: [Position] + positions = _positions + + +getSelectionRanges :: IdeState -> NormalizedFilePath -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null) +getSelectionRanges ide file positions = do + (codeRange, positionMapping) <- runIdeActionE "SelectionRange" (shakeExtras ide) $ useWithStaleFastE GetCodeRange file + -- 'positionMapping' should be applied to the input before using them + positions' <- + traverse (fromCurrentPositionE positionMapping) positions + + let selectionRanges = flip fmap positions' $ \pos -> + -- We need a default selection range if the lookup fails, + -- so that other positions can still have valid results. + let defaultSelectionRange = SelectionRange (Range pos pos) Nothing + in fromMaybe defaultSelectionRange . findPosition pos $ codeRange + + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT (PluginInvalidUserState "toCurrentSelectionRange") . MaybeT . pure $ + InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges + +-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. +findPosition :: Position -> CodeRange -> Maybe SelectionRange +findPosition pos root = go Nothing root + where + -- Helper function for recursion. The range list is built top-down + go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange + go acc node = + if positionInRange pos range + then maybe acc' (go acc') (binarySearchPos children) + -- If all children doesn't contain pos, acc' will be returned. + -- acc' will be Nothing only if we are in the root level. + else Nothing + where + range = _codeRange_range node + children = _codeRange_children node + acc' = Just $ maybe (SelectionRange range Nothing) (SelectionRange range . Just) acc + + binarySearchPos :: Vector CodeRange -> Maybe CodeRange + binarySearchPos v + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + let (left, right) = V.splitAt (V.length v `div` 2) v + startOfRight <- _start . _codeRange_range <$> V.headM right + if pos < startOfRight then binarySearchPos left else binarySearchPos right + +-- | Traverses through the code range and it children to a folding ranges. +-- +-- It starts with the root node, converts that into a folding range then moves towards the children. +-- It converts each child of each root node and parses it to folding range and moves to its children. +-- +-- Two cases to that are assumed to be taken care on the client side are: +-- +-- 1. When a folding range starts and ends on the same line, it is upto the client if it wants to +-- fold a single line folding or not. +-- +-- 2. As we are converting nodes of the ast into folding ranges, there are multiple nodes starting from a single line. +-- A single line of code doesn't mean a single node in AST, so this function removes all the nodes that have a duplicate +-- start line, ie. they start from the same line. +-- Eg. A multi-line function that also has a multi-line if statement starting from the same line should have the folding +-- according to the function. +-- +-- We think the client can handle this, if not we could change to remove these in future +-- +-- Discussion reference: https://github.com/haskell/haskell-language-server/pull/3058#discussion_r973737211 +findFoldingRanges :: CodeRange -> [FoldingRange] +findFoldingRanges codeRange = + -- removing the first node because it folds the entire file + drop1 $ findFoldingRangesRec codeRange + +findFoldingRangesRec :: CodeRange -> [FoldingRange] +findFoldingRangesRec r@(CodeRange _ children _) = + let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRangesRec children + in case createFoldingRange r of + Just x -> x:frChildren + Nothing -> frChildren + +-- | Parses code range to folding range +createFoldingRange :: CodeRange -> Maybe FoldingRange +createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do + -- Type conversion of codeRangeKind to FoldingRangeKind + let frk = crkToFrk ck + Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk) Nothing) + +-- | Likes 'toCurrentPosition', but works on 'SelectionRange' +toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange +toCurrentSelectionRange positionMapping SelectionRange{..} = do + newRange <- toCurrentRange positionMapping _range + pure $ SelectionRange { + _range = newRange, + _parent = _parent >>= toCurrentSelectionRange positionMapping + } diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CodeRange.ASTPreProcess + ( preProcessAST + , PreProcessEnv(..) + , isCustomNode + , CustomNodeType(..) + ) where + +import Control.Monad.Reader (Reader, asks) +import Data.Foldable +import Data.Functor.Identity (Identity (Identity, runIdentity)) +import Data.List (groupBy) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Semigroup (First (First, getFirst)) +import Data.Semigroup.Foldable (foldlM1) +import qualified Data.Set as Set +import Development.IDE.GHC.Compat hiding (nodeInfo) +import Prelude hiding (span) + +{-| +Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context +-} +newtype PreProcessEnv a = PreProcessEnv + { preProcessEnvRefMap :: RefMap a + } + +{-| +Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies +the AST to handle some special cases. + +'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as +a concrete example example. + +Adding another manipulation to the AST is simple, just implement a function of type +`HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`. + +If it goes more complex, it may be more appropriate to split different manipulations to different modules. +-} +preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition + +{-| +Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' +provided by GHC, but created to suite the needs of hls-code-range-plugin. +-} +createCustomNode :: CustomNodeType -> NonEmpty (HieAST a) -> HieAST a +createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEmpty.toList children) + where + span' :: RealSrcSpan + span' = runIdentity . foldlM1 (\x y -> Identity (combineRealSrcSpans x y)) . fmap nodeSpan $ children + + customNodeInfo = simpleNodeInfoCompat "HlsCustom" (customNodeTypeToFastString customNodeType) + +isCustomNode :: HieAST a -> Maybe CustomNodeType +isCustomNode node = do + nodeInfo <- generatedNodeInfo node + getFirst <$> foldMap go (nodeAnnotations nodeInfo) + where + go :: (FastStringCompat, FastStringCompat) -> Maybe (First CustomNodeType) + go (k, v) + | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') + | otherwise = Nothing + +data CustomNodeType = + -- | a group of imports + CustomNodeImportsGroup + -- | adjacent type signature and value definition are paired under a custom parent node + | CustomNodeAdjacentSignatureDefinition + deriving (Show, Eq, Ord) + +customNodeTypeMapping :: Map CustomNodeType FastStringCompat +customNodeTypeMapping = Map.fromList + [ (CustomNodeImportsGroup, "Imports") + , (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") + ] + +revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType +revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList $ customNodeTypeMapping + +customNodeTypeToFastString :: CustomNodeType -> FastStringCompat +customNodeTypeToFastString k = fromMaybe "" (customNodeTypeMapping Map.!? k) + +{-| +Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting +the whole import area while expanding/shrinking the selection range. +-} +mergeImports :: forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a) +mergeImports node = pure $ node { nodeChildren = children } + where + children :: [HieAST a] + children = mapMaybe merge + . groupBy (\x y -> nodeIsImport x && nodeIsImport y) + . nodeChildren $ node + + merge :: [HieAST a] -> Maybe (HieAST a) + merge [] = Nothing + merge [x] = Just x + merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) + +nodeIsImport :: HieAST a -> Bool +nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") + +{-| +Combine type signature with variable definition under a new parent node, if the signature is placed right before the +definition. This allows the user to have a step selecting both type signature and its accompanying definition. +-} +mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +mergeSignatureWithDefinition node = do + refMap <- asks preProcessEnvRefMap + -- Do this recursively for children, so that non top level functions can be handled. + children' <- traverse mergeSignatureWithDefinition (nodeChildren node) + pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' } + where + -- For every two adjacent nodes, we try to combine them into one. + go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a] + go _ [] node' = [node'] + go refMap (prev:others) node' = + case mergeAdjacentSigDef refMap (prev, node') of + Nothing -> node':prev:others + Just comb -> comb:others + +-- | Merge adjacent type signature and variable/function definition, if the type signature belongs to that variable or +-- function. +-- +-- The implementation potentially has some corner cases not handled properly. +mergeAdjacentSigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) +mergeAdjacentSigDef refMap (n1, n2) = do + -- Let's check the node's annotation. There should be a function binding following its type signature. + checkAnnotation + -- Find the identifier of the type signature. + typeSigId <- identifierForTypeSig n1 + -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. + refs <- Map.lookup typeSigId refMap + if any (isIdentADef (nodeSpan n2)) refs + then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2] + else Nothing + where + checkAnnotation :: Maybe () + checkAnnotation = + if ("TypeSig", "Sig") `isAnnotationInAstNode` n1 && + (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2) + then Just () + else Nothing + +{-| +Given the AST node of a type signature, tries to find the identifier of it. +-} +identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier +identifierForTypeSig node = + {- + It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in + its children recursively. + -} + case mapMaybe extractIdentifier nodes of + [] -> Nothing + (ident:_) -> Just ident + where + nodes = flattenAst node + + extractIdentifier :: HieAST a -> Maybe Identifier + extractIdentifier node' = sourceNodeInfo node' >>= + (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) + . Map.toList . nodeIdentifiers) + +-- | Determines if the given occurrence of an identifier is a function/variable definition in the outer span +isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool +isIdentADef outerSpan (span, detail) = + realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan + && isDef + where + isDef :: Bool + isDef = any isContextInfoDef . toList . identInfo $ detail + + -- Determines if the 'ContextInfo' represents a variable/function definition + isContextInfoDef :: ContextInfo -> Bool + isContextInfoDef ValBind{} = True + isContextInfoDef MatchBind = True + isContextInfoDef _ = False + +isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool +isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CodeRange.Rules + ( CodeRange (..) + , codeRange_range + , codeRange_children + , codeRange_kind + , CodeRangeKind(..) + , GetCodeRange(..) + , codeRangeRule + , Log(..) + + -- * Internal + , removeInterleaving + , simplify + , crkToFrk + ) where + +import Control.DeepSeq (NFData) +import qualified Control.Lens as Lens +import Control.Monad (foldM) +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.Reader (runReader) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + maybeToExceptT) +import Control.Monad.Trans.Writer.CPS +import Data.Coerce (coerce) +import Data.Data (Typeable) +import Data.Foldable (traverse_) +import Data.Function (on, (&)) +import Data.Hashable +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Vector (Vector) +import qualified Data.Vector as V +import Development.IDE +import Development.IDE.Core.Rules (toIdeResult) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HieAST (..), + HieASTs (getAsts), RefMap) +import Development.IDE.GHC.Compat.Util +import GHC.Generics (Generic) +import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), + PreProcessEnv (..), + isCustomNode, + preProcessAST) +import Language.LSP.Protocol.Types (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region)) + +import Language.LSP.Protocol.Lens (HasEnd (end), + HasStart (start)) +import Prelude hiding (log) + +data Log = LogShake Shake.Log + | LogNoAST + | LogFoundInterleaving CodeRange CodeRange + deriving Show + +instance Pretty Log where + pretty log = case log of + LogShake shakeLog -> pretty shakeLog + LogNoAST -> "no HieAst exist for file" + LogFoundInterleaving r1 r2 -> + let prettyRange = pretty . show . _codeRange_range + in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 + +-- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range +data CodeRange = CodeRange { + -- | Range for current level + _codeRange_range :: !Range, + -- | A vector of children, sorted by their ranges in ascending order. + -- Children are guaranteed not to interleave, but some gaps may exist among them. + _codeRange_children :: !(Vector CodeRange), + -- The kind of current code range + _codeRange_kind :: !CodeRangeKind + } + deriving (Show, Generic, NFData) + +-- | 'CodeKind' represents the kind of a code range +data CodeRangeKind = + -- | ordinary code + CodeKindRegion + -- | the group of imports + | CodeKindImports + -- | a comment + | CodeKindComment + deriving (Show, Eq, Generic, NFData) + +Lens.makeLenses ''CodeRange + +instance Eq CodeRange where + (==) = (==) `on` _codeRange_range + +instance Ord CodeRange where + compare :: CodeRange -> CodeRange -> Ordering + compare = compare `on` _codeRange_range + +-- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong, +-- a list of warnings will be returned as 'Log' +buildCodeRange :: HieAST a -> RefMap a -> Writer [Log] CodeRange +buildCodeRange ast refMap = do + -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding + -- range don't need to care about 'HieAST' + -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) + let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) + codeRange <- astToCodeRange ast' + pure $ simplify codeRange + +astToCodeRange :: HieAST a -> Writer [Log] CodeRange +astToCodeRange (Node _ sp []) = pure $ CodeRange (realSrcSpanToRange sp) mempty CodeKindRegion +astToCodeRange node@(Node _ sp children) = do + children' <- removeInterleaving . sort =<< traverse astToCodeRange children + let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion + pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind + +-- | Remove interleaving of the list of 'CodeRange's. +removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange] +removeInterleaving = fmap reverse . foldM go [] + where + -- we want to traverse from left to right (to make the logs easier to read) + go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange] + go [] x = pure [x] + go (x1:acc) x2 = do + -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range + -- compares it's start position first, the start position must be already in an ascending order. + -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving + -- must exist. + -- (Note: LSP Range's end position is exclusive) + x1' <- if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start + then do + -- set x1.end to x2.start + let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) + tell [LogFoundInterleaving x1 x2] + pure x1' + else pure x1 + pure $ x2:x1':acc + +-- | Remove redundant nodes in 'CodeRange' tree +simplify :: CodeRange -> CodeRange +simplify r = + case onlyChild of + -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. + Just onlyChild' -> + if _codeRange_range onlyChild' == curRange + then simplify (r { _codeRange_children = _codeRange_children onlyChild' }) + else withChildrenSimplified + Nothing -> withChildrenSimplified + where + curRange = _codeRange_range r + + onlyChild :: Maybe CodeRange = + let children = _codeRange_children r + in if V.length children == 1 then V.headM children else Nothing + + withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r } + +data GetCodeRange = GetCodeRange + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetCodeRange +instance NFData GetCodeRange + +type instance RuleResult GetCodeRange = CodeRange + +codeRangeRule :: Recorder (WithPriority Log) -> Rules () +codeRangeRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do + -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). + -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations + HAR{hieAst, refMap} <- lift $ use_ GetHieAst file + ast <- maybeToExceptT LogNoAST . MaybeT . pure $ + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + let (codeRange, warnings) = runWriter (buildCodeRange ast refMap) + traverse_ (logWith recorder Warning) warnings + + pure codeRange + +-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log) +handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a) +handleError recorder action' = do + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Warning msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) + +-- | Maps type CodeRangeKind to FoldingRangeKind +crkToFrk :: CodeRangeKind -> FoldingRangeKind +crkToFrk crk = case crk of + CodeKindComment -> FoldingRangeKind_Comment + CodeKindImports -> FoldingRangeKind_Imports + CodeKindRegion -> FoldingRangeKind_Region diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRange.RulesTest (testTree) where + +import Control.Monad.Trans.Writer.CPS +import Data.Bifunctor (Bifunctor (second)) +import qualified Data.Vector as V +import Ide.Plugin.CodeRange.Rules +import Test.Hls + +testTree :: TestTree +testTree = + testGroup "CodeRange.Rules" [ + testGroup "removeInterleaving" $ + let check :: [CodeRange] -> ([CodeRange], [Log]) -> Assertion + check input want = + second (fmap LogEq) (runWriter (removeInterleaving input)) @?= second (fmap LogEq) want + mkNode :: UInt -> UInt -> CodeRange + mkNode startCol endCol = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) [] CodeKindRegion + in [ + testCase "empty list" $ check [] ([], []), + testCase "one" $ check [mkNode 1 5] ([mkNode 1 5], []), + testCase "two, without intersection" $ check [mkNode 1 5, mkNode 5 6] ([mkNode 1 5, mkNode 5 6], []), + testCase "two, with intersection" $ let (x, y) = (mkNode 1 5, mkNode 2 4) + in check [x, y] ([mkNode 1 2, mkNode 2 4], [LogFoundInterleaving x y]), + testCase "three, with intersection" $ let (x, y, z) = (mkNode 1 10, mkNode 2 6, mkNode 4 12) + in check [x, y, z] ([mkNode 1 2, mkNode 2 4, mkNode 4 12], + [LogFoundInterleaving x y, LogFoundInterleaving y z]) + ], + testGroup "simplify" $ + let mkNode :: UInt -> UInt -> V.Vector CodeRange -> CodeRange + mkNode startCol endCol children = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) children CodeKindRegion + in [ + testCase "one level should not change" $ + let codeRange = mkNode 1 5 [] + in codeRange @=? simplify codeRange, + testCase "dedup 3 nested layers" $ + let input = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + ] + ] + want = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + in want @=? simplify input, + testCase "should not dedup node that has multiple children" $ + let input = + mkNode 1 10 [ + mkNode 1 10 [], + mkNode 2 10 [] + ] + in simplify input @?= input, + testCase "dedup simple two layers" $ + let input = mkNode 1 10 [ mkNode 1 10 []] + in simplify input @?= mkNode 1 10 [] + ] + ] + +newtype LogEq = LogEq Log + deriving Show + +instance Eq LogEq where + LogEq (LogShake _) == LogEq (LogShake _) = True + LogEq LogNoAST == LogEq LogNoAST = True + LogEq (LogFoundInterleaving left right) == LogEq (LogFoundInterleaving left' right') = + left == left' && right == right' + LogEq _ == LogEq _ = False diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRangeTest (testTree) where + +import qualified Data.Vector as V +import Ide.Plugin.CodeRange +import Ide.Plugin.CodeRange.Rules +import Test.Hls + +testTree :: TestTree +testTree = + testGroup "CodeRange" [ + testGroup "findPosition" $ + let check :: Position -> CodeRange -> Maybe SelectionRange -> Assertion + check position codeRange = (findPosition position codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange + mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion + in [ + testCase "not in range" $ check + (Position 10 1) + (mkCodeRange (Position 1 1) (Position 5 10) []) + Nothing, + testCase "in top level range" $ check + (Position 3 8) + (mkCodeRange (Position 1 1) (Position 5 10) []) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in the gap between children, in parent" $ check + (Position 3 6) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 1) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "before all children, in parent" $ check + (Position 1 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in children, in parent" $ check + (Position 2 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 2) (Position 3 6)) $ Just + ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing + ) + ) + ], + + -- TODO: Some more tests can be added on strange cases like + -- 1. lots of blank lines in between type signature and the body + -- 2. lots of blank lines in the function itself + -- etc. + testGroup "findFoldingRanges" $ + let check :: CodeRange -> [FoldingRange] -> Assertion + check codeRange = (findFoldingRanges codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange + mkCodeRange start end children crk = CodeRange (Range start end) children crk + in [ + -- General test + testCase "Test General Code Block" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + [], + + -- Tests for code kind + testCase "Test Code Kind Region" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing], + testCase "Test Code Kind Comment" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Comment) Nothing], + testCase "Test Code Kind Import" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Imports) Nothing], + + -- Test for Code Portions with children + testCase "Test Children" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [ + mkCodeRange (Position 1 3) (Position 1 5) [] CodeKindRegion + ] CodeKindRegion, + mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion + ] CodeKindRegion) + [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing + ] + ], + + testGroup "createFoldingRange" $ + let check :: CodeRange -> Maybe FoldingRange -> Assertion + check codeRange = (createFoldingRange codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange + mkCodeRange start end children crk = CodeRange (Range start end) children crk + in [ + -- General tests + testCase "Test General Code Block" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing)), + -- If a range has the same start and end line it need not be folded so Nothing is expected + testCase "Test Same Start Line" $ check + (mkCodeRange (Position 1 1) (Position 1 10) [] CodeKindRegion) + (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeKind_Region) Nothing)) + ] + ] diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Lens hiding (List, (<.>)) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBSChar8 +import Data.String (fromString) +import Ide.Plugin.CodeRange (Log, descriptor) +import qualified Ide.Plugin.CodeRange.RulesTest +import qualified Ide.Plugin.CodeRangeTest +import Language.LSP.Protocol.Lens (result) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import System.FilePath ((<.>), ()) +import Test.Hls + +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "codeRange" + +main :: IO () +main = do + defaultTestRunner $ + testGroup "Code Range" [ + testGroup "Integration Tests" [ + selectionRangeGoldenTest "Import" [(4, 36), (1, 8)], + selectionRangeGoldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], + selectionRangeGoldenTest "Empty" [(1, 5)], + foldingRangeGoldenTest "Function" + ], + testGroup "Unit Tests" [ + Ide.Plugin.CodeRangeTest.testTree, + Ide.Plugin.CodeRange.RulesTest.testTree + ] + ] + +selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree +selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer def plugin testDataDir $ do + doc <- openDoc (testName <.> "hs") "haskell" + resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions + let res = resp ^. result + pure $ fmap (showSelectionRangesForTest . absorbNull) res + case res of + Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure "" + Left err -> assertFailure (show err) + Right golden -> pure golden + where + testDataDir :: FilePath + testDataDir = "plugins" "hls-code-range-plugin" "test" "testdata" "selection-range" + + showSelectionRangesForTest :: [SelectionRange] -> ByteString + showSelectionRangesForTest selectionRanges = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges + + showSelectionRangeForTest :: SelectionRange -> ByteString + showSelectionRangeForTest selectionRange = go True (Just selectionRange) + where + go :: Bool -> Maybe SelectionRange -> ByteString + go _ Nothing = "" + go isFirst (Just (SelectionRange (Range sp ep) parent)) = + (if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent + showPosition :: Position -> ByteString + showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" + showLBS = fromString . show + +foldingRangeGoldenTest :: TestName -> TestTree +foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer def plugin testDataDir $ do + doc <- openDoc (testName <.> "hs") "haskell" + resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc + let res = resp ^. result + pure $ fmap (showFoldingRangesForTest . absorbNull) res + + case res of + Left err -> assertFailure (show err) + Right golden -> pure golden + + where + testDataDir :: FilePath + testDataDir = "plugins" "hls-code-range-plugin" "test" "testdata" "folding-range" + + showFoldingRangesForTest :: [FoldingRange] -> ByteString + showFoldingRangesForTest foldingRanges = (LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges) `LBSChar8.snoc` '\n' + + showFoldingRangeForTest :: FoldingRange -> ByteString + showFoldingRangeForTest (FoldingRange sl (Just sc) el (Just ec) (Just frk) _) = + "((" <> showLBS sl <> ", " <> showLBS sc <> ") : (" <> showLBS el <> ", " <> showLBS ec <> ")) : " <> showFRK frk + showFoldingRangeForTest fr = + "unexpected FoldingRange: " <> fromString (show fr) + + showLBS = fromString . show + showFRK = fromString . show diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs @@ -0,0 +1,1 @@ +module Empty where diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -0,0 +1,41 @@ +((2, 16) : (2, 22)) : FoldingRangeKind_Region +((4, 0) : (7, 21)) : FoldingRangeKind_Region +((4, 0) : (4, 25)) : FoldingRangeKind_Region +((4, 0) : (4, 6)) : FoldingRangeKind_Region +((4, 10) : (4, 25)) : FoldingRangeKind_Region +((4, 10) : (4, 17)) : FoldingRangeKind_Region +((4, 21) : (4, 25)) : FoldingRangeKind_Region +((5, 0) : (7, 21)) : FoldingRangeKind_Region +((5, 0) : (5, 6)) : FoldingRangeKind_Region +((5, 7) : (5, 8)) : FoldingRangeKind_Region +((5, 9) : (7, 21)) : FoldingRangeKind_Region +((5, 11) : (7, 21)) : FoldingRangeKind_Region +((5, 14) : (5, 28)) : FoldingRangeKind_Region +((5, 14) : (5, 23)) : FoldingRangeKind_Region +((5, 14) : (5, 15)) : FoldingRangeKind_Region +((5, 16) : (5, 21)) : FoldingRangeKind_Region +((5, 22) : (5, 23)) : FoldingRangeKind_Region +((5, 24) : (5, 26)) : FoldingRangeKind_Region +((5, 27) : (5, 28)) : FoldingRangeKind_Region +((6, 16) : (6, 20)) : FoldingRangeKind_Region +((7, 16) : (7, 21)) : FoldingRangeKind_Region +((9, 0) : (12, 20)) : FoldingRangeKind_Region +((9, 0) : (9, 24)) : FoldingRangeKind_Region +((9, 0) : (9, 5)) : FoldingRangeKind_Region +((9, 9) : (9, 24)) : FoldingRangeKind_Region +((9, 9) : (9, 16)) : FoldingRangeKind_Region +((9, 20) : (9, 24)) : FoldingRangeKind_Region +((10, 0) : (12, 20)) : FoldingRangeKind_Region +((10, 0) : (10, 5)) : FoldingRangeKind_Region +((10, 6) : (10, 7)) : FoldingRangeKind_Region +((10, 8) : (12, 20)) : FoldingRangeKind_Region +((10, 10) : (12, 20)) : FoldingRangeKind_Region +((10, 13) : (10, 27)) : FoldingRangeKind_Region +((10, 13) : (10, 22)) : FoldingRangeKind_Region +((10, 13) : (10, 14)) : FoldingRangeKind_Region +((10, 15) : (10, 20)) : FoldingRangeKind_Region +((10, 21) : (10, 22)) : FoldingRangeKind_Region +((10, 23) : (10, 25)) : FoldingRangeKind_Region +((10, 26) : (10, 27)) : FoldingRangeKind_Region +((11, 16) : (11, 21)) : FoldingRangeKind_Region +((12, 16) : (12, 20)) : FoldingRangeKind_Region diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use module export list" #-} +module Function(isEven) where + +isEven :: Integer -> Bool +isEven n = if n `mod` 2 == 0 + then True + else False + +isOdd :: Integer -> Bool +isOdd n = if n `mod` 2 == 0 + then False + else True diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "Function" + - "Empty" diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs @@ -0,0 +1,1 @@ +module Empty where diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt @@ -0,0 +1,4 @@ +(5,16) (5,20) => (5,16) (5,40) => (5,14) (11,20) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15) +(5,12) (5,13) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15) +(4,1) (4,9) => (4,1) (4,29) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15) +(3,1) (3,9) => (3,1) (3,61) => (3,1) (11,20) => (3,1) (14,15) diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs @@ -0,0 +1,14 @@ +module FuncMultiMatch where + +someFunc :: Integral a => a -> String -> Maybe (Int, String) +someFunc _ "magic" = Nothing +someFunc x y = Just (fromIntegral x, y) + where + go :: Int -> Int + go 0 = -1 + go x = x + 1 + + hi = "greeting" + +otherFunc :: String -> String +otherFunc = id diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt @@ -0,0 +1,2 @@ +(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47) +(1,8) (1,8) diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs @@ -0,0 +1,4 @@ +module MultiPositions where + +import Data.List (find) +import qualified Data.Foldable (foldl, foldl') diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - "Import" + - "Function" + - "Empty" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Eval Plugin entry point. +-} +module Ide.Plugin.Eval ( + descriptor, + Log(..) + ) where + +import Development.IDE (IdeState) +import Ide.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) +import qualified Ide.Plugin.Eval.CodeLens as CL +import Ide.Plugin.Eval.Config +import Ide.Plugin.Eval.Rules (rules) +import qualified Ide.Plugin.Eval.Rules as EvalRules +import Ide.Types (ConfigDescriptor (..), + PluginDescriptor (..), PluginId, + defaultConfigDescriptor, + defaultPluginDescriptor, + mkCustomConfig, mkPluginHandler) +import Language.LSP.Protocol.Message + +newtype Log = LogEvalRules EvalRules.Log deriving Show + +instance Pretty Log where + pretty = \case + LogEvalRules log -> pretty log + +-- |Plugin descriptor +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId "Provies a code lens to evaluate expressions in doctest comments") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens + , pluginCommands = [CL.evalCommand plId] + , pluginRules = rules (cmapWithPrio LogEvalRules recorder) + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties + } + } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} + +-- | Expression execution +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class +import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) +import qualified Data.List.NonEmpty as NE +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import GHC (ExecOptions, ExecResult (..), + execStmt) +import Ide.Plugin.Eval.Types (Language (Plain), Loc, + Located (..), + Section (sectionLanguage), + Test (..), Txt, locate, locate0) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Position (Position), + Range (Range)) +import System.IO.Extra (newTempFile, readFile') + +-- | Return the ranges of the expression and result parts of the given test +testRanges :: Test -> (Range, Range) +testRanges tst = + let startLine = testRange tst ^. L.start . L.line + (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst + resLine = startLine + exprLines + in ( Range + (Position startLine 0) + --(Position (startLine + exprLines + resultLines) 0), + (Position resLine 0) + , Range (Position resLine 0) (Position (resLine + resultLines) 0) + ) + +{- |The document range where a test is defined + testRange :: Loc Test -> Range + testRange = fst . testRanges +-} + +-- |The document range where the result of the test is defined +resultRange :: Test -> Range +resultRange = snd . testRanges + +-- TODO: handle BLANKLINE +{- +>>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] +["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] +-} +showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] +showDiffs = map showDiff + +showDiff :: (Semigroup a, IsString a) => Diff a -> a +showDiff (First w) = "WAS " <> w +showDiff (Second w) = "NOW " <> w +showDiff (Both w _) = w + +testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text] +testCheck diff (section, test) out + | not diff || null (testOutput test) || sectionLanguage section == Plain = out + | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out + +testLengths :: Test -> (Int, Int) +testLengths (Example e r _) = (NE.length e, length r) +testLengths (Property _ r _) = (1, length r) + +-- |A one-line Haskell statement +type Statement = Loc String + +asStatements :: Test -> [Statement] +asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. L.start . L.line) (asStmts lt) + +asStmts :: Test -> [Txt] +asStmts (Example e _ _) = NE.toList e +asStmts (Property t _ _) = + ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] + + + +-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result +myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) +myExecStmt stmt opts = do + (temp, purge) <- liftIO newTempFile + evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") + modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} + result <- execStmt stmt opts >>= \case + ExecComplete (Left err) _ -> pure $ Left $ show err + ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp + ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported" + liftIO purge + pure result + +{- |GHC declarations required to execute test properties + +Example: + +prop> \(l::[Bool]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. + +prop> \(l::[Bool]) -> reverse l == l +*** Failed! Falsified (after 6 tests and 2 shrinks): +[True,False] +-} +propSetup :: [Loc [Char]] +propSetup = + locate0 + [ ":set -XScopedTypeVariables -XExplicitForAll" + , "import qualified Test.QuickCheck as Q11" + , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display + ] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -0,0 +1,684 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-type-defaults -Wno-unused-imports #-} + +{- | +A plugin inspired by the REPLoid feature of , 's Examples and Properties and . + +For a full example see the "Ide.Plugin.Eval.Tutorial" module. +-} +module Ide.Plugin.Eval.CodeLens ( + codeLens, + evalCommand, +) where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (second, (>>>)) +import Control.Exception (bracket_, try) +import qualified Control.Exception as E +import Control.Lens (_1, _3, ix, (%~), + (<&>), (^.)) +import Control.Monad (guard, void, + when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) +import Data.Aeson (toJSON) +import Data.Char (isSpace) +import Data.Foldable (toList) +import Data.List (dropWhileEnd, + find, + intercalate, + intersperse) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Development.IDE.Core.Rules (IdeState, + runAction) +import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod), + NeedsCompilation (NeedsCompilation), + TypeCheck (..), + tmrTypechecked) +import Development.IDE.Core.Shake (useNoFile_, + useWithStale_, + use_, uses_) +import Development.IDE.GHC.Compat hiding (typeKind, + unitState) +import Development.IDE.GHC.Compat.Util (GhcException, + OverridingBool (..), + bagToList) +import Development.IDE.GHC.Util (evalGhcEnv, + modifyDynFlags, + printOutputable) +import Development.IDE.Import.DependencyInformation (transitiveDeps, + transitiveModuleDeps) +import Development.IDE.Types.Location (toNormalizedFilePath', + uriToFilePath') +import GHC (ClsInst, + ExecOptions (execLineNumber, execSourceFile), + FamInst, + GhcMonad, + NamedThing (getName), + defaultFixity, + execOptions, + exprType, + getInfo, + getInteractiveDynFlags, + isImport, isStmt, + parseName, + pprFamInst, + pprInstance, + typeKind) + + +import Development.IDE.Core.RuleTypes (GetLinkable (GetLinkable), + GetModSummary (GetModSummary), + GetModuleGraph (GetModuleGraph), + GhcSessionDeps (GhcSessionDeps), + ModSummaryResult (msrModSummary)) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) +import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), + unLoc) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) +import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) + +import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Core.PluginUtils +import Development.IDE.Types.Shake (toKey) +import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) +import Ide.Plugin.Error (PluginError (PluginInternalError), + handleMaybe, + handleMaybeM) +import Ide.Plugin.Eval.Code (Statement, + asStatements, + myExecStmt, + propSetup, + resultRange, + testCheck, + testRanges) +import Ide.Plugin.Eval.Config (EvalConfig (..), + getEvalConfig) +import Ide.Plugin.Eval.GHC (addImport, + addPackages, + hasPackage, + setSessionAndInteractiveDynFlags, + showDynFlags) +import Ide.Plugin.Eval.Parse.Comments (commentsToSections) +import Ide.Plugin.Eval.Parse.Option (parseSetFlags) +import Ide.Plugin.Eval.Rules (queueForEvaluation, + unqueueForEvaluation) +import Ide.Plugin.Eval.Types +import Ide.Plugin.Eval.Util (gStrictTry, + isLiterate, + logWith, + response', timed) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server +import Language.LSP.VFS (virtualFileText) + +{- | Code Lens provider + NOTE: Invoked every time the document is modified, not just when the document is saved. +-} +codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens +codeLens st plId CodeLensParams{_textDocument} = + let dbg = logWith st + perf = timed dbg + in perf "codeLens" $ + do + let TextDocumentIdentifier uri = _textDocument + fp <- uriToFilePathE uri + let nfp = toNormalizedFilePath' fp + isLHS = isLiterate fp + dbg "fp" fp + (comments, _) <- + runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp + -- dbg "excluded comments" $ show $ DL.toList $ + -- foldMap (\(L a b) -> + -- case b of + -- AnnLineComment{} -> mempty + -- AnnBlockComment{} -> mempty + -- _ -> DL.singleton (a, b) + -- ) + -- $ apiAnnComments' pm_annotations + dbg "comments" $ show comments + + -- Extract tests from source code + let Sections{..} = commentsToSections isLHS comments + tests = testsBySection nonSetupSections + cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) + let lenses = + [ CodeLens testRange (Just cmd') Nothing + | (section, ident, test) <- tests + , let (testRange, resultRange) = testRanges test + args = EvalParams (setupSections ++ [section]) _textDocument ident + cmd' = + (cmd :: Command) + { _arguments = Just [toJSON args] + , _title = + if trivial resultRange + then "Evaluate..." + else "Refresh..." + } + ] + + perf "tests" $ + dbg "Tests" $ + unwords + [ show (length tests) + , "tests in" + , show (length nonSetupSections) + , "sections" + , show (length setupSections) + , "setups" + , show (length lenses) + , "lenses." + ] + + return $ InL lenses + where + trivial (Range p p') = p == p' + +evalCommandName :: CommandId +evalCommandName = "evalCommand" + +evalCommand :: PluginId -> PluginCommand IdeState +evalCommand plId = PluginCommand evalCommandName "evaluate" (runEvalCmd plId) + +type EvalId = Int + +runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams +runEvalCmd plId st mtoken EvalParams{..} = + let dbg = logWith st + perf = timed dbg + cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit + cmd = do + let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections + + let TextDocumentIdentifier{_uri} = module_ + fp <- uriToFilePathE _uri + let nfp = toNormalizedFilePath' fp + mdlText <- moduleText _uri + + -- enable codegen for the module which we need to evaluate. + final_hscEnv <- liftIO $ bracket_ + (do queueForEvaluation st nfp + setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") + (do unqueueForEvaluation st nfp + setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") + (initialiseSessionForEval (needsQuickCheck tests) st nfp) + + evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId + + -- Perform the evaluation of the command + edits <- + perf "edits" $ + liftIO $ + evalGhcEnv final_hscEnv $ do + runTests evalCfg (st, fp) tests + + let workspaceEditsMap = Map.fromList [(_uri, addFinalReturn mdlText edits)] + let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing + + return workspaceEdits + in perf "evalCmd" $ ExceptT $ + withIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater -> + runExceptT $ response' cmd + +-- | Create an HscEnv which is suitable for performing interactive evaluation. +-- All necessary home modules will have linkables and the current module will +-- also be loaded into the environment. +-- +-- The interactive context and interactive dynamic flags are also set appropiately. +initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv +initialiseSessionForEval needs_quickcheck st nfp = do + (ms, env1) <- runAction "runEvalCmd" st $ do + + ms <- msrModSummary <$> use_ GetModSummary nfp + deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + + linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp + linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) + -- We unset the global rdr env in mi_globals when we generate interfaces + -- See Note [Clearing mi_globals after generating an iface] + -- However, the eval plugin (setContext specifically) requires the rdr_env + -- for the current module - so get it from the Typechecked Module and add + -- it back to the iface for the current module. + rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp + let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc + addRdrEnv hmi + | iface <- hm_iface hmi + , ms_mod ms == mi_module iface + = hmi { hm_iface = iface { mi_globals = Just $! +#if MIN_VERSION_ghc(9,8,0) + forceGlobalRdrEnv +#endif + rdr_env + }} + | otherwise = hmi + + return (ms, linkable_hsc) + -- Bit awkward we need to use evalGhcEnv here but setContext requires to run + -- in the Ghc monad + env2 <- liftIO $ evalGhcEnv env1 $ do + setContext [Compat.IIModule (moduleName (ms_mod ms))] + let df = flip xopt_set LangExt.ExtendedDefaultRules + . flip xopt_unset LangExt.MonomorphismRestriction + . flip gopt_set Opt_ImplicitImportQualified + . flip gopt_unset Opt_DiagnosticsShowCaret + $ (ms_hspp_opts ms) { + useColor = Never + , canUseColor = False } + modifyDynFlags (const df) + when needs_quickcheck $ void $ addPackages ["QuickCheck"] + getSession + return env2 + +addFinalReturn :: Text -> [TextEdit] -> [TextEdit] +addFinalReturn mdlText edits + | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = + finalReturn mdlText : edits + | otherwise = edits + +finalReturn :: Text -> TextEdit +finalReturn txt = + let ls = T.lines txt + l = fromIntegral $ length ls -1 + c = fromIntegral $ T.length . last $ ls + p = Position l c + in TextEdit (Range p p) "\n" + +moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text +moduleText uri = + handleMaybeM (PluginInternalError "mdlText") $ + (virtualFileText <$>) + <$> getVirtualFile + (toNormalizedUri uri) + +testsBySection :: [Section] -> [(Section, EvalId, Test)] +testsBySection sections = + [(section, ident, test) + | (ident, section) <- zip [0..] sections + , test <- sectionTests section + ] + +type TEnv = (IdeState, String) +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) + +runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] +runTests EvalConfig{..} e@(_st, _) tests = do + df <- getInteractiveDynFlags + evalSetup + when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup + + mapM (processTest e df) tests + where + processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit + processTest e@(st, fp) df (section, test) = do + let dbg = logWith st + let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) + rs <- runTest e df test + dbg "TEST RESULTS" rs + + let checkedResult = testCheck eval_cfg_diff (section, test) rs + let resultLines = concatMap T.lines checkedResult + + let edit = asEdit (sectionFormat section) test (map pad resultLines) + dbg "TEST EDIT" edit + return edit + + -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] + runTest _ df test + | not (hasQuickCheck df) && isProperty test = + return $ + singleLine + "Add QuickCheck to your cabal dependencies to run this test." + runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test) + +asEdit :: Format -> Test -> [Text] -> TextEdit +asEdit (MultiLine commRange) test resultLines + -- A test in a block comment, ending with @-\}@ without newline in-between. + | testRange test ^. L.end . L.line == commRange ^. L.end . L.line + = + TextEdit + (Range + (testRange test ^. L.end) + (resultRange test ^. L.end) + ) + ("\n" <> T.unlines (resultLines <> ["-}"])) +asEdit _ test resultLines = + TextEdit (resultRange test) (T.unlines resultLines) + +{- | +The result of evaluating a test line can be: +* a value +* nothing +* a (possibly multiline) error message + +A value is returned for a correct expression. + +Either a pure value: +>>> 'h' :"askell" +"haskell" + +Or an 'IO a' (output on stdout/stderr is ignored): +>>> print "OK" >> return "ABC" +"ABC" + +Nothing is returned for a correct directive: + +>>>:set -XFlexibleInstances +>>> import Data.Maybe + +Nothing is returned for a correct declaration (let..,x=, data, class) + +>>> let x = 11 +>>> y = 22 +>>> data B = T | F +>>> class C a + +Nothing is returned for an empty line: + +>>> + +A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code: + +>>>:set -XNonExistent +Some flags have not been recognized: -XNonExistent + +>>> cls C +Variable not in scope: cls :: t0 -> t +Data constructor not in scope: C + +>>> "A +lexical error in string/character literal at end of input + +Exceptions are shown as if printed, but it can be configured to include prefix like +in GHCi or doctest. This allows it to be used as a hack to simulate print until we +get proper IO support. See #1977 + +>>> 3 `div` 0 +divide by zero + +>>> error "Something went wrong\nbad times" :: E.SomeException +Something went wrong +bad times + +Or for a value that does not have a Show instance and can therefore not be displayed: +>>> data V = V +>>> V +No instance for (Show V) arising from a use of ‘evalPrint’ +-} +evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] +evals mark_exception (st, fp) df stmts = do + er <- gStrictTry $ mapM eval stmts + return $ case er of + Left err -> errorLines err + Right rs -> concat . catMaybes $ rs + where + dbg = logWith st + eval :: Statement -> Ghc (Maybe [Text]) + eval (Located l stmt) + | -- GHCi flags + Just (words -> flags) <- parseSetFlags stmt = do + dbg "{:SET" flags + ndf <- getInteractiveDynFlags + dbg "pre set" $ showDynFlags ndf + eans <- + liftIO $ try @GhcException $ + parseDynamicFlagsCmdLine ndf + (map (L $ UnhelpfulSpan unhelpfulReason) flags) + dbg "parsed flags" $ eans + <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings) + case eans of + Left err -> pure $ Just $ errorLines $ show err + Right (df', ignoreds, warns) -> do + let warnings = do + guard $ not $ null warns + pure $ errorLines $ + prettyWarnings warns + igns = do + guard $ not $ null ignoreds + pure + ["Some flags have not been recognized: " + <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) + ] + dbg "post set" $ showDynFlags df' + setSessionAndInteractiveDynFlags df' + pure $ warnings <> igns + | -- A type/kind command + Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = + evalGhciLikeCmd cmd arg + | -- A statement + isStmt pf stmt = + do + dbg "{STMT " stmt + res <- exec stmt l + let r = case res of + Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err + Right x -> singleLine <$> x + dbg "STMT} -> " r + return r + | -- An import + isImport pf stmt = + do + dbg "{IMPORT " stmt + _ <- addImport stmt + return Nothing + | -- A declaration + otherwise = + do + dbg "{DECL " stmt + void $ runDecls stmt + return Nothing + pf = initParserOpts df + unhelpfulReason = UnhelpfulInteractive + exec stmt l = + let opts = execOptions{execSourceFile = fp, execLineNumber = l} + in myExecStmt stmt opts + +#if MIN_VERSION_ghc(9,8,0) +prettyWarnings :: Messages DriverMessage -> String +prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage) +#else +prettyWarnings :: [Warn] -> String +prettyWarnings = unlines . map prettyWarn + +prettyWarn :: Warn -> String +prettyWarn Warn{..} = + T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" + <> " " <> SrcLoc.unLoc warnMsg +#endif + +needsQuickCheck :: [(Section, Test)] -> Bool +needsQuickCheck = any (isProperty . snd) + +hasQuickCheck :: DynFlags -> Bool +hasQuickCheck df = hasPackage df "QuickCheck" + +singleLine :: String -> [Text] +singleLine s = [T.pack s] + +{- | + Convert error messages to a list of text lines + Remove unnecessary information. +-} +errorLines :: String -> [Text] +errorLines = + dropWhileEnd T.null + . takeWhile (not . ("CallStack" `T.isPrefixOf`)) + . T.lines + . T.pack + +{- | + Convert exception messages to a list of text lines + Remove unnecessary information and mark it as exception. + We use '*** Exception:' to make it identical to doctest + output, see #2353. +-} +exceptionLines :: String -> [Text] +exceptionLines = (ix 0 %~ ("*** Exception: " <>)) . errorLines + +{- | +>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) +["--2+2","--"] +-} +pad_ :: Text -> Text -> Text +pad_ prefix = (prefix `T.append`) . convertBlank + +convertBlank :: Text -> Text +convertBlank x + | T.null x = "" + | otherwise = x + +padPrefix :: IsString p => Format -> p +padPrefix SingleLine = "-- " +padPrefix _ = "" + +{- | Resulting @Text@ MUST NOT prefix each line with @--@ + Such comment-related post-process will be taken place + solely in 'evalGhciLikeCmd'. +-} +type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text) + +-- Should we use some sort of trie here? +ghciLikeCommands :: [(Text, GHCiLikeCmd)] +ghciLikeCommands = + [ ("info", doInfoCmd False) + , ("info!", doInfoCmd True) + , ("kind", doKindCmd False) + , ("kind!", doKindCmd True) + , ("type", doTypeCmd) + ] + +evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) +evalGhciLikeCmd cmd arg = do + df <- getSessionDynFlags + case lookup cmd ghciLikeCommands + <|> snd + <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of + Just hndler -> + fmap + T.lines + <$> hndler df arg + _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg + +doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) +doInfoCmd allInfo dflags s = do + sdocs <- mapM infoThing (T.words s) + pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs) + where + infoThing :: GHC.GhcMonad m => Text -> m SDoc + infoThing (T.unpack -> str) = do + names <- GHC.parseName str + mb_stuffs <- mapM (GHC.getInfo allInfo) names + let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t) + (catMaybes $ toList mb_stuffs) + return $ vcat (intersperse (text "") $ map pprInfo filtered) + + filterOutChildren :: (a -> TyThing) -> [a] -> [a] + filterOutChildren get_thing xs + = filter (not . has_parent) xs + where + all_names = mkNameSet (map (getName . get_thing) xs) + has_parent x = case tyThingParent_maybe (get_thing x) of + Just p -> getName p `elemNameSet` all_names + Nothing -> False + + pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc + pprInfo (thing, fixity, cls_insts, fam_insts, docs) + = docs + $$ pprTyThingInContextLoc thing + $$ showFixity thing fixity + $$ vcat (map GHC.pprInstance cls_insts) + $$ vcat (map GHC.pprFamInst fam_insts) + + pprTyThingInContextLoc :: TyThing -> SDoc + pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext showToHeader tyThing) + + showWithLoc :: SDoc -> SDoc -> SDoc + showWithLoc loc doc + = hang doc 2 (text "\t--" <+> loc) + + showFixity :: TyThing -> Fixity -> SDoc + showFixity thing fixity + | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing) + = ppr fixity <+> pprInfixName (GHC.getName thing) + | otherwise = empty + +doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) +doKindCmd False df arg = do + let input = T.strip arg + (_, kind) <- typeKind False $ T.unpack input + let kindText = text (T.unpack input) <+> "::" <+> pprSigmaType kind + pure $ Just $ T.pack (showSDoc df kindText) +doKindCmd True df arg = do + let input = T.strip arg + (ty, kind) <- typeKind True $ T.unpack input + let kindDoc = text (T.unpack input) <+> "::" <+> pprSigmaType kind + tyDoc = "=" <+> pprSigmaType ty + pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) + +doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) +doTypeCmd dflags arg = do + let (emod, expr) = parseExprMode arg + ty <- GHC.exprType emod $ T.unpack expr + let rawType = T.strip $ T.pack $ showSDoc dflags $ pprSigmaType ty + broken = T.any (\c -> c == '\r' || c == '\n') rawType + pure $ + Just $ + if broken + then + T.pack $ + showSDoc dflags $ + text (T.unpack expr) + $$ nest 2 ("::" <+> pprSigmaType ty) + else expr <> " :: " <> rawType <> "\n" + +parseExprMode :: Text -> (TcRnExprMode, T.Text) +parseExprMode rawArg = case T.break isSpace rawArg of + ("+d", rest) -> (TM_Default, T.strip rest) + _ -> (TM_Inst, rawArg) + +data GhciLikeCmdException = GhciLikeCmdNotImplemented + { ghciCmdName :: Text + , ghciCmdArg :: Text + } + deriving (Typeable) + +instance Show GhciLikeCmdException where + showsPrec _ GhciLikeCmdNotImplemented{..} = + showString "unknown command '" + . showString (T.unpack ghciCmdName) + . showChar '\'' + +instance E.Exception GhciLikeCmdException + +{- +>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1") +Just ("kind!","N + M + 1") +>>> parseGhciLikeCmd (T.pack ":kind a") +Just ("kind","a") +-} +parseGhciLikeCmd :: Text -> Maybe (Text, Text) +parseGhciLikeCmd input = do + (':', rest) <- T.uncons $ T.stripStart input + pure $ second T.strip $ T.break isSpace rest diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Eval.Config + ( properties + , getEvalConfig + , EvalConfig(..) + ) where + +import Development.IDE +import Ide.Plugin.Properties +import Ide.Types (PluginId) + +-- | The Eval plugin configuration. (see 'properties') +data EvalConfig = EvalConfig + { eval_cfg_diff :: Bool + , eval_cfg_exception :: Bool + } + deriving (Eq, Ord, Show) + +properties :: Properties + '[ 'PropertyKey "exception" 'TBoolean + , 'PropertyKey "diff" 'TBoolean + ] +properties = emptyProperties + & defineBooleanProperty #diff + "Enable the diff output (WAS/NOW) of eval lenses" True + & defineBooleanProperty #exception + "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi." False + +getEvalConfig :: PluginId -> Action EvalConfig +getEvalConfig plId = + EvalConfig + <$> usePropertyAction #diff plId properties + <*> usePropertyAction #exception plId properties diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-} + +-- |GHC API utilities +module Ide.Plugin.Eval.GHC ( + addExtension, + addImport, + hasPackage, + addPackages, + modifyFlags, + showDynFlags, + setSessionAndInteractiveDynFlags, +) where + +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.String (fromString) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import qualified Development.IDE.GHC.Compat.Util as EnumSet +import Development.IDE.GHC.Util (printOutputable) + +import GHC.LanguageExtensions.Type (Extension (..)) +import Ide.Plugin.Eval.Util (gStrictTry) + +#if MIN_VERSION_ghc(9,3,0) +import GHC (setTopSessionDynFlags, + setUnitDynFlags) +import GHC.Driver.Env +import GHC.Driver.Session (getDynFlags) +#endif + +{- $setup +>>> import GHC +>>> import GHC.Paths +>>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act) +>>> libdir +"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4" +-} + +{- | True if specified package is present in DynFlags + +-- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg) +>>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg)) + +>>> hasPackageTst "base" +Right True + +>>> hasPackageTst "ghc" +Right True + +>>> hasPackageTst "extra" +Left ": cannot satisfy -package extra\n (use -v for more information)" + +>>> hasPackageTst "QuickCheck" +Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" +-} +hasPackage :: DynFlags -> String -> Bool +hasPackage df = hasPackage_ (packageFlags df) + +hasPackage_ :: [PackageFlag] -> [Char] -> Bool +hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags) + +{- | +>>> run (return . pkgNames) +[] +-} +pkgNames :: DynFlags -> [String] +pkgNames = pkgNames_ . packageFlags + +pkgNames_ :: [PackageFlag] -> [String] +pkgNames_ = + mapMaybe + ( \case + ExposePackage _ (PackageArg n) _ -> Just n + ExposePackage _ (UnitIdArg uid) _ -> Just $ T.unpack $ printOutputable uid + _ -> Nothing + ) + +{- | Expose a list of packages. +>>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs) + +>>> addPackagesTest [] +Right [] + +>>> addPackagesTest ["base","base","array"] +Right [-package base{package base True ([])},-package array{package array True ([])}] + +>>> addPackagesTest ["Cabal"] +Right [-package Cabal{package Cabal True ([])}] + +>>> addPackagesTest ["QuickCheck"] +Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" + +>>> addPackagesTest ["base","notThere"] +Left ": cannot satisfy -package notThere\n (use -v for more information)" + +prop> \(x::Int) -> x + x == 2 * x ++++ OK, passed 100 tests. +-} +addPackages :: [String] -> Ghc (Either String DynFlags) +addPackages pkgNames = gStrictTry $ + modifyFlags $ \df -> + df{packageFlags = foldr (\pkgName pf -> if hasPackage_ pf pkgName then pf else expose pkgName : pf) (packageFlags df) pkgNames} + where + expose name = ExposePackage ("-package " ++ name) (PackageArg name) (ModRenaming True []) + +modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags +modifyFlags f = do + df <- getSessionDynFlags + _ <- setSessionDynFlags (f df) + getSessionDynFlags + +-- modifyFlags f = do +-- modifyDynFlags f +-- getSessionDynFlags + +{- | Add import to evaluation context + +>>> run $ \_ -> addImport "import Data.Maybe" +Could not find module ‘Data.Maybe’ +Use -v (or `:set -v` in ghci) to see a list of the files searched for. + +>>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe" +[import Data.Maybe] + +>>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M" +[import qualified Data.Maybe as M] +-} +addImport :: GhcMonad m => String -> m [InteractiveImport] +addImport i = do + ctx <- getContext + -- dbgO "CONTEXT" ctx + idecl <- parseImportDecl i + setContext $ IIDecl idecl : ctx + -- ctx' <- getContext + -- dbg "CONTEXT'" ctx' + getContext + +{- | Add extension to interactive evaluation session +>>> import GHC.LanguageExtensions.Type(Extension(..)) +>>> run $ \_ -> addExtension DeriveGeneric +() +-} +addExtension :: GhcMonad m => Extension -> m () +addExtension ext = + modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext} + +setExtension :: InteractiveContext -> Extension -> InteractiveContext +setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext} + +deriving instance Read Extension + +-- Partial display of DynFlags contents, for testing purposes +showDynFlags :: DynFlags -> String +showDynFlags df = + T.unpack . printOutputable . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $ + [ ("extensions", ppr . extensions $ df) + , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df) + , ("importPaths", vList $ importPaths df) + , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df) + , -- , ("includePaths", text . show $ includePaths df) + -- ("packageEnv", ppr $ packageEnv df) + ("pkgNames", vcat . map text $ pkgNames df) + , ("packageFlags", vcat . map ppr $ packageFlags df) + -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df) + -- ("pkgDatabase", text . show <$> pkgDatabase $ df) + ] + +vList :: [String] -> SDoc +vList = vcat . map text + +setSessionAndInteractiveDynFlags :: DynFlags -> Ghc () +setSessionAndInteractiveDynFlags df = do +#if MIN_VERSION_ghc(9,3,0) + _ <- setUnitDynFlags (homeUnitId_ df) df + modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ df)) + df' <- getDynFlags + setTopSessionDynFlags df' +#else + _ <- setSessionDynFlags df +#endif + sessDyns <- getSessionDynFlags + setInteractiveDynFlags sessDyns diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Ide.Plugin.Eval.Parse.Comments where + +import qualified Control.Applicative.Combinators.NonEmpty as NE +import Control.Arrow (first, (&&&), (>>>)) +import Control.Lens (lensField, lensRules, + view, (.~), (^.)) +import Control.Lens.Extras (is) +import Control.Lens.TH (makeLensesWith, + makePrisms, + mappingNamer) +import Control.Monad (guard, void, when) +import Control.Monad.Combinators () +import Control.Monad.Reader (ask) +import Control.Monad.Trans.Reader (Reader, runReader) +import qualified Data.Char as C +import qualified Data.DList as DL +import qualified Data.Foldable as F +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Void (Void) +import GHC.Generics hiding (UInt, to) +import Ide.Plugin.Eval.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types + +import qualified Text.Megaparsec as P +import Text.Megaparsec +import Text.Megaparsec.Char (alphaNumChar, char, + eol, hspace, + letterChar) + +{- +We build parsers combining the following three kinds of them: + + * Line parser - paring a single line into an input, + works both for line- and block-comments. + A line should be a proper content of lines contained in comment: + doesn't include starting @--@ and @{\-@ and no ending @-\}@ + + * Line comment group parser: parses a contiguous group of + tuples of position and line comment into sections of line comments. + Each input MUST start with @--@. + + * Block comment parser: Parsing entire block comment into sections. + Input must be surrounded by @{\-@ and @-\}@. +-} + +-- | Line parser +type LineParser a = forall m. Monad m => ParsecT Void String m a + +-- | Line comment group parser +type LineGroupParser = Parsec Void [(Range, RawLineComment)] + +data BlockEnv = BlockEnv + { isLhs :: Bool + , blockRange :: Range + } + deriving (Show, Eq, Ord) + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''BlockEnv + +-- | Block comment parser +type BlockCommentParser = ParsecT Void String (Reader BlockEnv) + +-- | Prop line, with "prop>" stripped off +newtype PropLine = PropLine {getPropLine :: String} + deriving (Show) + +-- | Example line, with @>>>@ stripped off +newtype ExampleLine = ExampleLine {getExampleLine :: String} + deriving (Show) + +data TestComment + = AProp + { testCommentRange :: Range + , lineProp :: PropLine + , propResults :: [String] + } + | AnExample + { testCommentRange :: Range + , lineExamples :: NonEmpty ExampleLine + , exampleResults :: [String] + } + deriving (Show) + +-- | Classification of comments +data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String + deriving (Read, Show, Eq, Ord) + +-- | Single line or block comments? +data CommentStyle = Line | Block Range + deriving (Show, Eq, Ord, Generic) + +makePrisms ''CommentStyle + +commentsToSections :: + -- | True if it is literate Haskell + Bool -> + Comments -> + Sections +commentsToSections isLHS Comments {..} = + let (lineSectionSeeds, lineSetupSeeds) = + foldMap + ( \lcs -> + let theRan = + Range + (view L.start $ fst $ NE.head lcs) + (view L.end $ fst $ NE.last lcs) + in case parseMaybe lineGroupP $ NE.toList lcs of + Nothing -> mempty + Just (mls, rs) -> + ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) + , -- orders setup sections in ascending order + if null rs + then mempty + else + Map.singleton theRan $ + DL.singleton (Line, rs) + ) + ) + $ groupLineComments $ + Map.filterWithKey + -- FIXME: + -- To comply with the initial behaviour of + -- Extended Eval Plugin; + -- but it also rejects modules with + -- non-zero base indentation level! + ( \pos _ -> + if isLHS + then pos ^. L.start . L.character == 2 + else pos ^. L.start . L.character == 0 + ) + lineComments + (blockSeed, blockSetupSeeds) = + foldMap + ( \(ran, lcs) -> + case parseBlockMaybe isLHS ran blockCommentBP $ + getRawBlockComment lcs of + Nothing -> mempty + Just (Named "setup", grp) -> + -- orders setup sections in ascending order + ( mempty + , Map.singleton ran $ + DL.singleton (Block ran, grp) + ) + Just grp -> + ( Map.singleton ran grp + , mempty + ) + ) + -- It seems Extended Eval Plugin doesn't constraint + -- starting indentation level for block comments. + -- Rather, it constrains the indentation level /inside/ + -- block comment body. + $ Map.toList blockComments + lineSections = + lineSectionSeeds <&> uncurry (testsToSection Line) + multilineSections = + Map.mapWithKey + (uncurry . testsToSection . Block) + blockSeed + setupSections = + -- Setups doesn't need Dummy position + map + ( \(style, tests) -> + testsToSection + style + (Named "setup") + tests + ) + $ DL.toList $ + F.fold $ + Map.unionWith (<>) lineSetupSeeds blockSetupSeeds + nonSetupSections = F.toList $ lineSections `Map.union` multilineSections + in Sections {..} + +parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a +parseBlockMaybe isLhs blockRange p i = + case runReader (runParserT p' "" i) BlockEnv {..} of + Left {} -> Nothing + Right a -> Just a + where + p' = do + updateParserState $ \st -> + st + { statePosState = + (statePosState st) + { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start + } + } + p + +type CommentRange = Range + +type SectionRange = Range + +testsToSection :: + CommentStyle -> + CommentFlavour -> + [TestComment] -> + Section +testsToSection style flav tests = + let sectionName + | Named name <- flav = name + | otherwise = "" + sectionLanguage = case flav of + HaddockNext -> Haddock + HaddockPrev -> Haddock + _ -> Plain + sectionTests = map fromTestComment tests + sectionFormat = + case style of + Line -> SingleLine + Block ran -> MultiLine ran + in Section {..} + +fromTestComment :: TestComment -> Test +fromTestComment AProp {..} = + Property + { testline = getPropLine lineProp + , testOutput = propResults + , testRange = testCommentRange + } +fromTestComment AnExample {..} = + Example + { testLines = getExampleLine <$> lineExamples + , testOutput = exampleResults + , testRange = testCommentRange + } + +-- * Block comment parser + +{- $setup +>>> dummyPos = Position 0 0 +>>> parseE p = either (error . errorBundlePretty) id . parse p "" +-} + +-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" +-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) + +blockCommentBP :: + -- | True if Literate Haskell + BlockCommentParser (CommentFlavour, [TestComment]) +blockCommentBP = do + skipCount 2 anySingle -- "{-" + void $ optional $ char ' ' + flav <- commentFlavourP + hit <- skipNormalCommentBlock + if hit + then do + body <- + many $ + (blockExamples <|> blockProp) + <* skipNormalCommentBlock + void takeRest -- just consume the rest + pure (flav, body) + else pure (flav, []) + +skipNormalCommentBlock :: BlockCommentParser Bool +skipNormalCommentBlock = do + BlockEnv {..} <- ask + skipManyTill (normalLineP isLhs $ Block blockRange) $ + False <$ try (optional (chunk "-}") *> eof) + <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) + +testSymbol :: Bool -> CommentStyle -> LineParser () +testSymbol isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> (exampleSymbol <|> propSymbol) + +eob :: LineParser () +eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol + +blockExamples + , blockProp :: + BlockCommentParser TestComment +blockExamples = do + BlockEnv {..} <- ask + (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange + AnExample ran examples <$> resultBlockP +blockProp = do + BlockEnv {..} <- ask + (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange + AProp ran prop <$> resultBlockP + +withRange :: + (TraversableStream s, Ord v, Traversable t) => + ParsecT v s m (t (a, Position)) -> + ParsecT v s m (Range, t a) +withRange p = do + beg <- sourcePosToPosition <$> getSourcePos + as <- p + let fin + | null as = beg + | otherwise = snd $ last $ F.toList as + pure (Range beg fin, fst <$> as) + +resultBlockP :: BlockCommentParser [String] +resultBlockP = do + BlockEnv {..} <- ask + many $ + fmap fst $ nonEmptyNormalLineP isLhs $ + Block blockRange + +positionToSourcePos :: Position -> SourcePos +positionToSourcePos pos = + P.SourcePos + { sourceName = "" + , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. L.line + , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. L.character + } + +sourcePosToPosition :: SourcePos -> Position +sourcePosToPosition SourcePos {..} = + Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1) + +-- * Line Group Parser + +{- | +Result: a tuple of ordinary line tests and setting sections. + +TODO: Haddock comment can adjacent to vanilla comment: + + @ + -- Vanilla comment + -- Another vanilla + -- | This parses as Haddock comment as GHC + @ + +This behaviour is not yet handled correctly in Eval Plugin; +but for future extension for this, we use a tuple here instead of 'Either'. +-} +lineGroupP :: + LineGroupParser + (Maybe (CommentFlavour, [TestComment]), [TestComment]) +lineGroupP = do + (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) + case flav of + Named "setup" -> (Nothing,) <$> lineCommentSectionsP + flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP + +-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] +-- Variable not in scope: dummyPosition :: Position + +commentFlavourP :: LineParser CommentFlavour +commentFlavourP = + P.option + Vanilla + ( HaddockNext <$ char '|' + <|> HaddockPrev <$ char '^' + <|> Named <$ char '$' + <* optional hspace + <*> ((:) <$> letterChar <*> P.many alphaNumChar) + ) + <* optional (char ' ') + +lineCommentHeadP :: LineParser () +lineCommentHeadP = do + -- and no operator symbol character follows. + void $ chunk "--" + skipMany $ char '-' + void $ optional $ char ' ' + +lineCommentSectionsP :: + LineGroupParser [TestComment] +lineCommentSectionsP = do + skipMany normalLineCommentP + many $ + exampleLinesGP + <|> uncurry AProp <$> propLineGP <*> resultLinesP + <* skipMany normalLineCommentP + +lexemeLine :: LineGroupParser a -> LineGroupParser a +lexemeLine p = p <* skipMany normalLineCommentP + +resultLinesP :: LineGroupParser [String] +resultLinesP = many nonEmptyLGP + +normalLineCommentP :: LineGroupParser (Range, String) +normalLineCommentP = + parseLine (fst <$ commentFlavourP <*> normalLineP False Line) + +nonEmptyLGP :: LineGroupParser String +nonEmptyLGP = + try $ + fmap snd $ + parseLine $ + fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line + +exampleLinesGP :: LineGroupParser TestComment +exampleLinesGP = + lexemeLine $ + uncurry AnExample . first convexHullRange . NE.unzip + <$> NE.some exampleLineGP + <*> resultLinesP + +convexHullRange :: NonEmpty Range -> Range +convexHullRange nes = + Range (NE.head nes ^. L.start) (NE.last nes ^. L.end) + +exampleLineGP :: LineGroupParser (Range, ExampleLine) +exampleLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) + +propLineGP :: LineGroupParser (Range, PropLine) +propLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) + +{- | +Turning a line parser into line group parser consuming a single line comment. +Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. +fails if the input does not start with "--". + +__N.B.__ We don't strip comment flavours. + +>>> pck = (:[]).(:[]) . RawLineComment + +>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" +Just [">>> A"] + +>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" +Just [" >>> A"] + +>>> parseMaybe (parseLine takeRest) $ pck "" +Nothing +-} +parseLine :: + (Ord (f RawLineComment), Traversable f) => + LineParser a -> + Parsec Void [f RawLineComment] (f a) +parseLine p = + P.token + (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) + mempty + +-- * Line Parsers + +-- | Non-empty normal line. +nonEmptyNormalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +nonEmptyNormalLineP isLHS style = try $ do + (ln, pos) <- normalLineP isLHS style + guard $ + case style of + Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] + _ -> not $ all C.isSpace ln + pure (ln, pos) + +{- | Normal line is a line neither a example nor prop. + Empty line is normal. +-} +normalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +normalLineP isLHS style = do + notFollowedBy + (try $ testSymbol isLHS style) + when (isLHS && is _Block style) $ + void $ count' 0 2 $ char ' ' + consume style + +consume :: CommentStyle -> LineParser (String, Position) +consume style = + case style of + Line -> (,) <$> takeRest <*> getPosition + Block {} -> manyTill_ anySingle (getPosition <* eob) + +getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position +getPosition = sourcePosToPosition <$> getSourcePos + +-- | Parses example test line. +exampleLineStrP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (ExampleLine, Position) +exampleLineStrP isLHS style = + try $ + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> exampleSymbol + *> (first ExampleLine <$> consume style) + +exampleSymbol :: LineParser () +exampleSymbol = + chunk ">>>" *> P.notFollowedBy (char '>') + +propSymbol :: LineParser () +propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') + +-- | Parses prop test line. +propLineStrP :: + -- | True if Literate HAskell + Bool -> + CommentStyle -> + LineParser (PropLine, Position) +propLineStrP isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> chunk "prop>" + *> P.notFollowedBy (char '>') + *> (first PropLine <$> consume style) + +-- * Utilities + +{- | +Given a sequence of tokens increasing in their starting position, +groups them into sublists consisting of contiguous tokens; +Two adjacent tokens are considered to be contiguous if + + * line number increases by 1, and + * they have same starting column. + +>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] +[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] +-} +contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a] +contiguousGroupOn toLineCol = foldr step [] + where + step a [] = [pure a] + step a bss0@((b :| bs) : bss) + | let (aLine, aCol) = toLineCol a + , let (bLine, bCol) = toLineCol b + , aLine + 1 == bLine && aCol == bCol = + (a :| b : bs) : bss + | otherwise = pure a : bss0 + +{- | Given a map from positions, divides them into subgroup + with contiguous line and columns. +-} +groupLineComments :: + Map Range a -> [NonEmpty (Range, a)] +groupLineComments = + contiguousGroupOn (fst >>> view L.start >>> view L.line &&& view L.character) + . Map.toList diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wwarn #-} + +-- | GHC language options parser +module Ide.Plugin.Eval.Parse.Option ( + langOptions, + parseSetFlags, +) where + +import Control.Arrow (left) +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char + +{- | +>>> langOptions ":set -XBinaryLiterals -XOverloadedStrings " +Right ["BinaryLiterals","OverloadedStrings"] + +>>> langOptions ":set" +Right [] + +>>> langOptions "" +Left "No match" +-} +langOptions :: String -> Either String [String] +langOptions = + left errorBundlePretty + . parse (space *> languageOpts <* eof) "" + +parseSetFlags :: String -> Maybe String +parseSetFlags = parseMaybe + (hspace *> chunk ":set" + *> hspace1 *> takeRest + :: Parsec Void String String + ) + +-- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings" +-- Just ["BinaryLiterals","OverloadedStrings"] +languageOpts :: Parsec Void String [String] +languageOpts = string ":set" *> space1 + *> many (string "-X" *> many letterChar <* space) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +-- To avoid warning "Pattern match has inaccessible right hand side" +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.IORef +import qualified Data.Map.Strict as Map +import Data.String (fromString) +import Development.IDE (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps), + GetParsedModuleWithComments (GetParsedModuleWithComments), + IdeState, + NeedsCompilation (NeedsCompilation), + NormalizedFilePath, + RuleBody (RuleNoDiagnostics), + Rules, defineEarlyCutoff, + encodeLinkableType, + fromNormalizedFilePath, + msrModSummary, + realSrcSpanToRange, + useWithStale_, + use_) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags, + needsCompilationRule) +import Development.IDE.Core.Shake (IsIdeGlobal, + RuleBody (RuleWithCustomNewnessCheck), + addIdeGlobal, + getIdeGlobalAction, + getIdeGlobalState) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat as SrcLoc +import qualified Development.IDE.GHC.Compat.Util as FastString +import Development.IDE.Graph (alwaysRerun) +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) +import GHC.Parser.Annotation +import Ide.Plugin.Eval.Types + +import qualified Data.ByteString as BS + +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + +rules :: Recorder (WithPriority Log) -> Rules () +rules recorder = do + evalParsedModuleRule recorder + redefinedNeedsCompilation recorder + isEvaluatingRule recorder + addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) + +newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath)) +instance IsIdeGlobal EvaluatingVar + +queueForEvaluation :: IdeState -> NormalizedFilePath -> IO () +queueForEvaluation ide nfp = do + EvaluatingVar var <- getIdeGlobalState ide + atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ())) + +unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO () +unqueueForEvaluation ide nfp = do + EvaluatingVar var <- getIdeGlobalState ide + -- remove the module from the Evaluating state, so that next time it won't evaluate to True + atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ()) + +#if MIN_VERSION_ghc(9,5,0) +getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment] +getAnnotations (L _ m@(HsModule { hsmodExt = XModulePs {hsmodAnn = anns'}})) = +#else +getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment] +getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) = +#endif + priorComments annComments <> getFollowingComments annComments + <> concatMap getCommentsForDecl (hsmodImports m) + <> concatMap getCommentsForDecl (hsmodDecls m) + where + annComments = epAnnComments anns' + +getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e + -> [LEpaComment] +getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs +getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = [] + +apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok] +apiAnnComments' pm = do + L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm + pure (L (anchor span) c) + +pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan +pattern RealSrcSpanAlready x = x + +evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () +evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do + (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp + let comments = foldMap (\case + L (RealSrcSpanAlready real) bdy + | FastString.unpackFS (srcSpanFile real) == + fromNormalizedFilePath nfp + , let ran0 = realSrcSpanToRange real + , Just curRan <- toCurrentRange posMap ran0 + -> + + -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', + -- we can concentrate on these two + case bdy of + EpaLineComment cmt -> + mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } + EpaBlockComment cmt -> + mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } + _ -> mempty + _ -> mempty + ) + $ apiAnnComments' pm + -- we only care about whether the comments are null + -- this is valid because the only dependent is NeedsCompilation + fingerPrint = fromString $ if nullComments comments then "" else "1" + return (Just fingerPrint, Just comments) + +isEvaluatingRule :: Recorder (WithPriority Log) -> Rules () +isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do + alwaysRerun + EvaluatingVar var <- getIdeGlobalAction + b <- liftIO $ (f `Set.member`) <$> readIORef var + return (Just (if b then BS.singleton 1 else BS.empty), Just b) + +-- Redefine the NeedsCompilation rule to set the linkable type to Just _ +-- whenever the module is being evaluated +-- This will ensure that the modules are loaded with linkables +-- and the interactive session won't try to compile them on the fly, +-- leading to much better performance of the evaluate code lens +redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules () +redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do + isEvaluating <- use_ IsEvaluating f + + if not isEvaluating then needsCompilationRule f else do + ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f + let df' = ms_hspp_opts ms + linkableType = computeLinkableTypeForDynFlags df' + fp = encodeLinkableType $ Just linkableType + + pure (Just fp, Just (Just linkableType)) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wwarn #-} + +module Ide.Plugin.Eval.Types + ( locate, + locate0, + Test (..), + isProperty, + Format (..), + Language (..), + Section (..), + Sections (..), + hasTests, + hasPropertyTest, + splitSections, + Loc, + Located (..), + Comments (..), + RawBlockComment (..), + RawLineComment (..), + unLoc, + Txt, + EvalParams(..), + GetEvalComments(..), + IsEvaluating(..), + nullComments) +where + +import Control.DeepSeq (deepseq) +import Data.Aeson (FromJSON, ToJSON) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.String (IsString (..)) +import Development.IDE (Range, RuleResult) +import Development.IDE.Graph.Classes +import GHC.Generics (Generic) +import Language.LSP.Protocol.Types (TextDocumentIdentifier) +import qualified Text.Megaparsec as P + +-- | A thing with a location attached. +data Located l a = Located {location :: l, located :: a} + deriving (Eq, Show, Ord, Functor, Generic, FromJSON, ToJSON) + +-- | Discard location information. +unLoc :: Located l a -> a +unLoc (Located _ a) = a + +instance (NFData l, NFData a) => NFData (Located l a) where + rnf (Located loc a) = loc `deepseq` a `deepseq` () + +type Loc = Located Line + +type Line = Int + +locate :: Loc [a] -> [Loc a] +locate (Located l tst) = zipWith Located [l ..] tst + +locate0 :: [a] -> [Loc a] +locate0 = locate . Located 0 + +type Txt = String + +data Sections = Sections + { nonSetupSections :: [Section] + , setupSections :: [Section] + } + deriving (Show, Eq, Generic) + +data Section = Section + { sectionName :: Txt + , sectionTests :: [Test] + , sectionLanguage :: Language + , sectionFormat :: Format + } + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +hasTests :: Section -> Bool +hasTests = not . null . sectionTests + +hasPropertyTest :: Section -> Bool +hasPropertyTest = any isProperty . sectionTests + +-- |Split setup and normal sections +splitSections :: [Section] -> ([Section], [Section]) +splitSections = partition ((== "setup") . sectionName) + +data Test + = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range} + | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +data IsEvaluating = IsEvaluating + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsEvaluating +instance NFData IsEvaluating + +type instance RuleResult IsEvaluating = Bool + +data GetEvalComments = GetEvalComments + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetEvalComments +instance NFData GetEvalComments + +type instance RuleResult GetEvalComments = Comments +data Comments = Comments + { lineComments :: Map Range RawLineComment + , blockComments :: Map Range RawBlockComment + } + deriving (Show, Eq, Ord, Generic) + +nullComments :: Comments -> Bool +nullComments Comments{..} = null lineComments && null blockComments + +instance NFData Comments + +newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + , NFData + ) + +newtype RawLineComment = RawLineComment {getRawLineComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + , NFData + ) + +instance Semigroup Comments where + Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs') + +instance Monoid Comments where + mempty = Comments mempty mempty + +isProperty :: Test -> Bool +isProperty Property {} = True +isProperty _ = False + +data Format + = SingleLine + | -- | @Range@ is that of surrounding entire block comment, not section. + -- Used for detecting no-newline test commands. + MultiLine Range + deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) + +data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData) + +data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +instance IsString ExpectedLine where + fromString = ExpectedLine . return . LineChunk + +data LineChunk = LineChunk String | WildCardChunk + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +instance IsString LineChunk where + fromString = LineChunk + +type EvalId = Int + +-- | Specify the test section to execute +data EvalParams = EvalParams + { sections :: [Section] + , module_ :: !TextDocumentIdentifier + , evalId :: !EvalId -- ^ unique group id; for test uses + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} + +-- |Debug utilities +module Ide.Plugin.Eval.Util ( + timed, + isLiterate, + response', + gStrictTry, + logWith, +) where + +import Control.Exception (SomeException, evaluate, + fromException) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) +import Data.Aeson (Value) +import Data.Bifunctor (second) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE (IdeState, Priority (..), + ideLogger, logPriority) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.GHC.Compat.Outputable +import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, + catch) +import GHC.Exts (toList) +import GHC.Stack (HasCallStack, callStack, + srcLocFile, + srcLocStartCol, + srcLocStartLine) +import Ide.Plugin.Error +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server +import System.FilePath (takeExtension) +import System.Time.Extra (duration, showDuration) +import UnliftIO.Exception (catchAny) + +timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b +timed out name op = do + (secs, r) <- duration op + _ <- out name (showDuration secs) + return r + +-- | Log using hie logger, reports source position of logging statement +logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () +logWith state key val = + liftIO . logPriority (ideLogger state) logLevel $ + T.unwords + [T.pack logWithPos, asT key, asT val] + where + logWithPos = + let stk = toList callStack + pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos] + in case stk of + [] -> "" + (x:_) -> pr $ snd x + + asT :: Show a => a -> T.Text + asT = T.pack . show + +-- | Set to Info to see extensive debug info in hie log, set to Debug in production +logLevel :: Priority +logLevel = Debug -- Info + +isLiterate :: FilePath -> Bool +isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] + +response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null) +response' act = do + res <- ExceptT (runExceptT act + `catchAny` \e -> do + res <- showErr e + pure . Left . PluginInternalError $ fromString res) + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + pure $ InR Null + +gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) +gStrictTry op = + catch + (op >>= fmap Right . gevaluate) + (fmap Left . showErr) + +gevaluate :: MonadIO m => a -> m a +gevaluate = liftIO . evaluate + +showErr :: Monad m => SomeException -> m String +showErr e = +#if MIN_VERSION_ghc(9,3,0) + case fromException e of + -- On GHC 9.4+, the show instance adds the error message span + -- We don't want this for the plugin + -- So render without the span. + Just (SourceError msgs) -> return $ renderWithContext defaultSDocContext + $ vcat + $ bagToList + $ fmap (vcat . unDecorated + . diagnosticMessage +#if MIN_VERSION_ghc(9,5,0) + (defaultDiagnosticOpts @GhcMessage) +#endif + . errMsgDiagnostic) + $ getMessages msgs + _ -> +#endif + return . show $ e diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Main + ( main + ) where + +import Control.Lens (_Just, folded, preview, view, (^.), + (^..)) +import Data.Aeson (Value (Object), fromJSON, object, + (.=)) +import Data.Aeson.Types (Pair, Result (Success)) +import Data.List (isInfixOf) +import Data.List.Extra (nubOrdOn) +import qualified Data.Map as Map +import Data.Row +import qualified Data.Text as T +import Ide.Plugin.Config (Config) +import qualified Ide.Plugin.Config as Plugin +import qualified Ide.Plugin.Eval as Eval +import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), + testOutput) +import Language.LSP.Protocol.Lens (command, range, title) +import System.FilePath ((<.>), ()) +import Test.Hls +import qualified Test.Hls.FileSystem as FS + +main :: IO () +main = defaultTestRunner tests + +evalPlugin :: PluginTestDescriptor Eval.Log +evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval" + +tests :: TestTree +tests = + testGroup "eval" + [ testCase "Produces Evaluate code lenses" $ + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] + , testCase "Produces Refresh code lenses" $ + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] + , testCase "Code lenses have ranges" $ + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Multi-line expressions have a multi-line range" $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T3.hs") $ do + doc <- openDoc "T3.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] + , testCase "Executed expressions range covers only the expression" $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] + + , goldenWithEval "Evaluation of expressions" "T1" "hs" + , goldenWithEval "Reevaluation of expressions" "T2" "hs" + , goldenWithEval "Evaluation of expressions w/ imports" "T3" "hs" + , goldenWithEval "Evaluation of expressions w/ lets" "T4" "hs" + , goldenWithEval "Refresh an evaluation" "T5" "hs" + , goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs" + , goldenWithEval "Refresh a multiline evaluation" "T7" "hs" + , goldenWithEval "Evaluate a multi-line show result" "TMultiResult" "hs" -- Do not escape from comments! + , testCase "Semantic and Lexical errors are reported" $ do + evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" + evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ + if + | ghcVersion >= GHC96 -> "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’" + | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’" + evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input" + evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False + , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" + , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" ( + if ghcVersion >= GHC94 then "ghc94.expected" + else if ghcVersion >= GHC92 then "ghc92.expected" + else "expected" + ) + , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069 + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" + , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" + , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" + , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" + , expectFailBecause "known issue - see a note in P.R. #361" $ + goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , testCase ":type handles a multilined result properly" $ + evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ + "-- fun", + if + | ghcVersion >= GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." + | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." + | otherwise -> "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- (KnownNat k2, KnownNat n, Typeable a) =>", + "-- Proxy k2 -> Proxy n -> Proxy a -> ()" + ] + , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs" + , testCase ":type does \"dovetails\" for short identifiers" $ + evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ + if + | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." + | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." + | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- (KnownNat k2, KnownNat n, Typeable a) =>", + "-- Proxy k2 -> Proxy n -> Proxy a -> ()" + ] + , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs" + , goldenWithEval ":kind treats a multilined result properly" "T25" "hs" + , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs" + , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs" + , goldenWithEval "Multi line comments" "TMulti" "hs" + , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs" + , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs" + , goldenWithEval "Evaluate expressions in Haddock comments in both single line and multi line format" "THaddock" "hs" + , goldenWithEval "Compare results (for Haddock tests only)" "TCompare" "hs" + , goldenWithEvalAndFs "Local Modules imports are accessible in a test" (FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) "TLocalImport" "hs" + , goldenWithEvalAndFs "Transitive local dependency" (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "TTransitive" "hs" + -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" + , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" + , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , testCase ":set -fprint-explicit-foralls works" $ do + evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" + evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" + (if ghcVersion >= GHC92 + then "-- id :: forall a. a -> a" + else "-- id :: forall {a}. a -> a") + , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" + , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" + , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" + , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" ( + if ghcVersion >= GHC98 then + "ghc98.expected" + else if ghcVersion >= GHC96 then + "ghc96.expected" + else if ghcVersion >= GHC94 then + "ghc94.expected" + else + "expected" + ) + , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" + , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" + , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs" + , goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs" + , testGroup "with preprocessors" + [ knownBrokenInEnv [HostOS Windows] + "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $ + goldenWithEval "CPP support" "TCPP" "hs" + , goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs" + ] + , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs" + , goldenWithEval "Variable 'it' works" "TIt" "hs" + , testGroup "configuration" + [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default" + , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig + , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False) + , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True) + ] + , testGroup ":info command" + [ testCase ":info reports type, constructors and instances" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + , testCase ":info reports type, constructors and instances for multiple types" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoMany.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration" + "Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar" + "Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar" + not ("Baz Bar" `isInfixOf` output) @? "Output includes instance Baz Bar" + , testCase ":info! reports type, constructors and unfiltered instances" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBang.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + "Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo" + , testCase ":info! reports type, constructors and unfiltered instances for multiple types" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBangMany.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + "Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo" + "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration" + "Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar" + "Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar" + "Baz Bar" `isInfixOf` output @? "Output does not include instance Baz Bar" + , testCase ":i behaves exactly the same as :info" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TI_Info.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + ] + , testCase "Interfaces are reused after Eval" $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) $ do + doc <- openDoc "TLocalImport.hs" "haskell" + _ <- waitForTypecheck doc + lenses <- getCodeLenses doc + cmd <- liftIO $ case lenses^..folded.command._Just of + [cmd] -> (cmd^.title @?= "Evaluate...") >> pure cmd + cmds -> assertFailure $ "Expected a single command, got " <> show (length cmds) + + executeCmd cmd + + -- trigger a rebuild and check that dependency interfaces are not rebuilt + changeDoc doc [] + _ <- waitForTypecheck doc + Right keys <- getLastBuildKeys + let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys + liftIO $ ifaceKeys @?= [] + ] + +goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree +goldenWithEval title path ext = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards + +goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs title tree path ext = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path "expected" ext executeLensesBackwards + +-- | Similar function as 'goldenWithEval' with an alternate reference file +-- naming. Useful when reference file may change because of GHC version. +goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree +goldenWithEval' title path ext expected = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path expected ext executeLensesBackwards + +goldenWithEvalAndFs' :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs' title tree path ext expected = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path expected ext executeLensesBackwards + + +-- | Execute lenses backwards, to avoid affecting their position in the source file +executeLensesBackwards :: TextDocumentIdentifier -> Session () +executeLensesBackwards doc = do + codeLenses <- reverse <$> getCodeLenses doc + -- liftIO $ print codeLenses + + -- Execute sequentially, nubbing elements to avoid + -- evaluating the same section with multiple tests + -- more than twice + mapM_ executeCmd $ + nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses] + +actSectionId :: Command -> Int +actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId +actSectionId _ = error "Invalid CodeLens" + +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _ <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + -- liftIO $ print _resp + pure () + +evalLenses :: FilePath -> IO [CodeLens] +evalLenses path = runSessionWithServerInTmpDir def evalPlugin (mkFs cabalProjectFS) $ do + doc <- openDoc path "haskell" + executeLensesBackwards doc + getCodeLenses doc + +codeLensTestOutput :: CodeLens -> [String] +codeLensTestOutput codeLens = do + CodeLens { _command = Just command } <- [codeLens] + Command { _arguments = Just args } <- [command] + Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args + Section { sectionTests = sectionTests } <- sections + testOutput =<< sectionTests + +testDataDir :: FilePath +testDataDir = "plugins" "hls-eval-plugin" "test" "testdata" + +changeConfig :: [Pair] -> Config +changeConfig conf = + def + { Plugin.plugins = Map.fromList [("eval", + def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object conf } + )] } + where + unObject (Object obj) = obj + unObject _ = undefined + +diffOffConfig :: Config +diffOffConfig = changeConfig ["diff" .= False] + +exceptionConfig :: Bool -> Config +exceptionConfig exCfg = changeConfig ["exception" .= exCfg] + +goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree +goldenWithEvalConfig' title path ext expected cfg = + goldenWithHaskellDocInTmpDir cfg evalPlugin title (mkFs $ FS.directProject $ path <.> ext) path expected ext $ \doc -> do + executeLensesBackwards doc + +evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () +evalInFile fp e expected = runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject fp) $ do + doc <- openDoc fp "haskell" + origin <- documentContents doc + let withEval = origin <> e + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval] + executeLensesBackwards doc + result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc + liftIO $ result @?= Just (T.strip expected) + +-- ---------------------------------------------------------------------------- +-- File system definitions +-- Used for declaring a test file tree +-- ---------------------------------------------------------------------------- + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +cabalProjectFS :: [FS.FileTree] +cabalProjectFS = FS.simpleCabalProject' + [ FS.copy "test.cabal" + , FS.file "cabal.project" + (FS.text "packages: ./info-util .\n" + ) + , FS.copy "TProperty.hs" + , FS.copy "TPropertyError.hs" + , FS.copy "TI_Info.hs" + , FS.copy "TInfo.hs" + , FS.copy "TInfoBang.hs" + , FS.copy "TInfoBangMany.hs" + , FS.copy "TInfoMany.hs" + , FS.directory "info-util" + [ FS.copy "info-util/info-util.cabal" + , FS.copy "info-util/InfoUtil.hs" + ] + ] diff --git a/plugins/hls-eval-plugin/test/cabal.project b/plugins/hls-eval-plugin/test/cabal.project new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/cabal.project @@ -0,0 +1,3 @@ +packages: + testdata/ + info-util/ diff --git a/plugins/hls-eval-plugin/test/testdata/T1.expected.hs b/plugins/hls-eval-plugin/test/testdata/T1.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T1.expected.hs @@ -0,0 +1,8 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T1.hs b/plugins/hls-eval-plugin/test/testdata/T1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T1.hs @@ -0,0 +1,7 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T10.expected.hs b/plugins/hls-eval-plugin/test/testdata/T10.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T10.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 +-- N + M + 1 :: Nat +-- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 +-- N + M + 1 :: Natural +-- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 +-- N + M + 1 :: Natural +-- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T10.hs b/plugins/hls-eval-plugin/test/testdata/T10.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T10.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 diff --git a/plugins/hls-eval-plugin/test/testdata/T11.expected.hs b/plugins/hls-eval-plugin/test/testdata/T11.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T11.expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! A +-- Not in scope: type constructor or class ‘A’ diff --git a/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs b/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! A +-- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/T11.hs b/plugins/hls-eval-plugin/test/testdata/T11.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T11.hs @@ -0,0 +1,3 @@ +module T11 where + +-- >>> :kind! A diff --git a/plugins/hls-eval-plugin/test/testdata/T12.expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T12.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Nat diff --git a/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Natural diff --git a/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Natural diff --git a/plugins/hls-eval-plugin/test/testdata/T12.hs b/plugins/hls-eval-plugin/test/testdata/T12.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T12.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 diff --git a/plugins/hls-eval-plugin/test/testdata/T13.expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T13.expected.hs @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind A +-- Not in scope: type constructor or class ‘A’ diff --git a/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind A +-- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind a +-- Not in scope: type variable `a' diff --git a/plugins/hls-eval-plugin/test/testdata/T13.hs b/plugins/hls-eval-plugin/test/testdata/T13.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T13.hs @@ -0,0 +1,3 @@ +module T13 where + +-- >>> :kind A diff --git a/plugins/hls-eval-plugin/test/testdata/T14.expected.hs b/plugins/hls-eval-plugin/test/testdata/T14.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T14.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int +-- foo @Int :: Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T14.ghc98.expected.hs b/plugins/hls-eval-plugin/test/testdata/T14.ghc98.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T14.ghc98.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int +-- foo @Int :: Show Int => Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T14.hs b/plugins/hls-eval-plugin/test/testdata/T14.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T14.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int diff --git a/plugins/hls-eval-plugin/test/testdata/T15.expected.hs b/plugins/hls-eval-plugin/test/testdata/T15.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T15.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T15 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type +v foo @Int +-- foo @Int :: Show Int => Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T15 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type +v foo @Int +-- foo @Int :: Show Int => Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T15.hs b/plugins/hls-eval-plugin/test/testdata/T15.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T15.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +module T15 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type +v foo @Int diff --git a/plugins/hls-eval-plugin/test/testdata/T16.expected.hs b/plugins/hls-eval-plugin/test/testdata/T16.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T16.expected.hs @@ -0,0 +1,4 @@ +module T16 where + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer diff --git a/plugins/hls-eval-plugin/test/testdata/T16.hs b/plugins/hls-eval-plugin/test/testdata/T16.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T16.hs @@ -0,0 +1,3 @@ +module T16 where + +-- >>> :type +d 40+ 2 diff --git a/plugins/hls-eval-plugin/test/testdata/T17.expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T17.expected.hs @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input ‘+’ diff --git a/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input `+' diff --git a/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input ‘+’ diff --git a/plugins/hls-eval-plugin/test/testdata/T17.hs b/plugins/hls-eval-plugin/test/testdata/T17.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T17.hs @@ -0,0 +1,3 @@ +module T17 where + +-- >>> :type +no 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T18.expected.hs b/plugins/hls-eval-plugin/test/testdata/T18.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T18.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar +-- unknown command 'noooop' diff --git a/plugins/hls-eval-plugin/test/testdata/T18.hs b/plugins/hls-eval-plugin/test/testdata/T18.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T18.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar diff --git a/plugins/hls-eval-plugin/test/testdata/T19.expected.hs b/plugins/hls-eval-plugin/test/testdata/T19.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T19.expected.hs @@ -0,0 +1,7 @@ +module T19 where +import Data.Word (Word) +type W = Word + +-- >>> default (Word) +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/plugins/hls-eval-plugin/test/testdata/T19.hs b/plugins/hls-eval-plugin/test/testdata/T19.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T19.hs @@ -0,0 +1,6 @@ +module T19 where +import Data.Word (Word) +type W = Word + +-- >>> default (Word) +-- >>> :type +d 40+ 2 diff --git a/plugins/hls-eval-plugin/test/testdata/T2.expected.hs b/plugins/hls-eval-plugin/test/testdata/T2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T2.expected.hs @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T2.hs b/plugins/hls-eval-plugin/test/testdata/T2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T2.hs @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "Stale output" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T20.expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T20.expected.hs @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer diff --git a/plugins/hls-eval-plugin/test/testdata/T20.hs b/plugins/hls-eval-plugin/test/testdata/T20.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T20.hs @@ -0,0 +1,6 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 diff --git a/plugins/hls-eval-plugin/test/testdata/T21.hs b/plugins/hls-eval-plugin/test/testdata/T21.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T21.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T21 where +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +fun _ _ _ = () + diff --git a/plugins/hls-eval-plugin/test/testdata/T22.expected.hs b/plugins/hls-eval-plugin/test/testdata/T22.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T22.expected.hs @@ -0,0 +1,10 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f +-- f :: Integer diff --git a/plugins/hls-eval-plugin/test/testdata/T22.hs b/plugins/hls-eval-plugin/test/testdata/T22.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T22.hs @@ -0,0 +1,9 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f diff --git a/plugins/hls-eval-plugin/test/testdata/T23.hs b/plugins/hls-eval-plugin/test/testdata/T23.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T23.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T23 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +f _ _ _ = () + diff --git a/plugins/hls-eval-plugin/test/testdata/T24.expected.hs b/plugins/hls-eval-plugin/test/testdata/T24.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T24.expected.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double)))))))))))) +-- = 'Next +-- ('Next +-- ('Next +-- ('Next ('Next ('Next ('Next ('Next ('Next ('Next 'Stop))))))))) diff --git a/plugins/hls-eval-plugin/test/testdata/T24.hs b/plugins/hls-eval-plugin/test/testdata/T24.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T24.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/plugins/hls-eval-plugin/test/testdata/T25.expected.hs b/plugins/hls-eval-plugin/test/testdata/T25.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T25.expected.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double)))))))))))) diff --git a/plugins/hls-eval-plugin/test/testdata/T25.hs b/plugins/hls-eval-plugin/test/testdata/T25.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T25.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/plugins/hls-eval-plugin/test/testdata/T26.expected.hs b/plugins/hls-eval-plugin/test/testdata/T26.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T26.expected.hs @@ -0,0 +1,5 @@ +module T26 where +import Util () + +-- >>> "hello" +-- "hello" diff --git a/plugins/hls-eval-plugin/test/testdata/T26.hs b/plugins/hls-eval-plugin/test/testdata/T26.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T26.hs @@ -0,0 +1,4 @@ +module T26 where +import Util () + +-- >>> "hello" diff --git a/plugins/hls-eval-plugin/test/testdata/T27.expected.hs b/plugins/hls-eval-plugin/test/testdata/T27.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T27.expected.hs @@ -0,0 +1,5 @@ +module T27 where + +-- >>> () +-- () +-- diff --git a/plugins/hls-eval-plugin/test/testdata/T27.hs b/plugins/hls-eval-plugin/test/testdata/T27.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T27.hs @@ -0,0 +1,4 @@ +module T27 where + +-- >>> () +-- diff --git a/plugins/hls-eval-plugin/test/testdata/T3.expected.hs b/plugins/hls-eval-plugin/test/testdata/T3.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T3.expected.hs @@ -0,0 +1,8 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T3.hs b/plugins/hls-eval-plugin/test/testdata/T3.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T3.hs @@ -0,0 +1,7 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T4.expected.hs b/plugins/hls-eval-plugin/test/testdata/T4.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T4.expected.hs @@ -0,0 +1,10 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] + diff --git a/plugins/hls-eval-plugin/test/testdata/T4.hs b/plugins/hls-eval-plugin/test/testdata/T4.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T4.hs @@ -0,0 +1,9 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +example :: [String] +example = ["This","is","an","example","of"] + diff --git a/plugins/hls-eval-plugin/test/testdata/T5.expected.hs b/plugins/hls-eval-plugin/test/testdata/T5.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T5.expected.hs @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T5.hs b/plugins/hls-eval-plugin/test/testdata/T5.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T5.hs @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/T6.expected.hs b/plugins/hls-eval-plugin/test/testdata/T6.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T6.expected.hs @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/plugins/hls-eval-plugin/test/testdata/T6.hs b/plugins/hls-eval-plugin/test/testdata/T6.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T6.hs @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/plugins/hls-eval-plugin/test/testdata/T7.expected.hs b/plugins/hls-eval-plugin/test/testdata/T7.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T7.expected.hs @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is an example of" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/plugins/hls-eval-plugin/test/testdata/T7.hs b/plugins/hls-eval-plugin/test/testdata/T7.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T7.hs @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is a stale example of" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/plugins/hls-eval-plugin/test/testdata/T8.hs b/plugins/hls-eval-plugin/test/testdata/T8.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T8.hs @@ -0,0 +1,2 @@ +-- An empty playground +module T8 where diff --git a/plugins/hls-eval-plugin/test/testdata/T9.expected.hs b/plugins/hls-eval-plugin/test/testdata/T9.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T9.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +module T9 where +import Data.Proxy (Proxy(..)) + +type P = Proxy + +-- >>> Proxy :: Proxy 3 +-- Proxy diff --git a/plugins/hls-eval-plugin/test/testdata/T9.hs b/plugins/hls-eval-plugin/test/testdata/T9.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T9.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +module T9 where +import Data.Proxy (Proxy(..)) + +type P = Proxy + +-- >>> Proxy :: Proxy 3 diff --git a/plugins/hls-eval-plugin/test/testdata/TCPP.expected.hs b/plugins/hls-eval-plugin/test/testdata/TCPP.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TCPP.expected.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +-- 11 +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +-- 14 +#else +-- >>> 5+y +#endif + +-- >>> 2+y +-- 13 diff --git a/plugins/hls-eval-plugin/test/testdata/TCPP.hs b/plugins/hls-eval-plugin/test/testdata/TCPP.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TCPP.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +#else +-- >>> 5+y +#endif + +-- >>> 2+y diff --git a/plugins/hls-eval-plugin/test/testdata/TCompare.expected.hs b/plugins/hls-eval-plugin/test/testdata/TCompare.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TCompare.expected.hs @@ -0,0 +1,13 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 4 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- WAS 5 +-- NOW 4 diff --git a/plugins/hls-eval-plugin/test/testdata/TCompare.hs b/plugins/hls-eval-plugin/test/testdata/TCompare.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TCompare.hs @@ -0,0 +1,12 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 5 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- 5 diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs @@ -0,0 +1,8 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- WAS 4 +-- NOW 5 +myId :: a -> a +myId x = x diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs @@ -0,0 +1,7 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- 5 +myId :: a -> a +myId x = x diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.hs @@ -0,0 +1,7 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- 4 +myId :: a -> a +myId x = x diff --git a/plugins/hls-eval-plugin/test/testdata/TEndingMulti.expected.hs b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.expected.hs @@ -0,0 +1,9 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54 +42 +54 +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs @@ -0,0 +1,6 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54-} diff --git a/plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs b/plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs @@ -0,0 +1,6 @@ +module TException where + +-- >>> exceptionalCode +-- *** Exception: I am exceptional! +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs b/plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs @@ -0,0 +1,6 @@ +module TException where + +-- >>> exceptionalCode +-- I am exceptional! +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/plugins/hls-eval-plugin/test/testdata/TException.hs b/plugins/hls-eval-plugin/test/testdata/TException.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TException.hs @@ -0,0 +1,5 @@ +module TException where + +-- >>> exceptionalCode +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs @@ -0,0 +1,62 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +Too many parameters for class ‘L’ +(Enable MultiParamTypeClasses to allow multi-parameter classes) +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D +No parameters for class ‘D’ +(Enable MultiParamTypeClasses to allow no-parameter classes) + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all +: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all + +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs @@ -0,0 +1,64 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +Too many parameters for class `L' +(Enable MultiParamTypeClasses to allow multi-parameter classes) +In the class declaration for `L' +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D +No parameters for class `D' +(Enable MultiParamTypeClasses to allow no-parameter classes) +In the class declaration for `D' + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all +: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all + +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc98.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc98.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc98.expected.hs @@ -0,0 +1,62 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +Too many parameters for class `L' +In the class declaration for `L' +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D +No parameters for class `D' +In the class declaration for `D' + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all +: warning: [GHC-53692] [-Wdeprecated-flags (in -Wdefault)] + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all + +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.hs @@ -0,0 +1,55 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all + +-} diff --git a/plugins/hls-eval-plugin/test/testdata/THaddock.expected.hs b/plugins/hls-eval-plugin/test/testdata/THaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/THaddock.expected.hs @@ -0,0 +1,42 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" +-- "ab" + +{- | Multi line comment + +>>> "b"++"c" +"bc" +-} + +double :: Num a => a -> a +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 +-- 22 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +"ABCABC" +-} + +{- | >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five :: Integer +five = 5 diff --git a/plugins/hls-eval-plugin/test/testdata/THaddock.hs b/plugins/hls-eval-plugin/test/testdata/THaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/THaddock.hs @@ -0,0 +1,37 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" + +{- | Multi line comment + +>>> "b"++"c" +-} + +double :: Num a => a -> a +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +-} + +{- | >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five :: Integer +five = 5 diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.hs b/plugins/hls-eval-plugin/test/testdata/TIO.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIO.hs @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TI_Info.hs b/plugins/hls-eval-plugin/test/testdata/TI_Info.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TI_Info.hs @@ -0,0 +1,5 @@ +module TI_Info (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :i Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfo.hs b/plugins/hls-eval-plugin/test/testdata/TInfo.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfo.hs @@ -0,0 +1,5 @@ +module TInfo (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs b/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoBang.hs @@ -0,0 +1,5 @@ +module TInfoBang (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info! Foo diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs b/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoBangMany.hs @@ -0,0 +1,5 @@ +module TInfoBangMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info! Foo Bar diff --git a/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs b/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TInfoMany.hs @@ -0,0 +1,5 @@ +module TInfoMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info Foo Bar diff --git a/plugins/hls-eval-plugin/test/testdata/TIt.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIt.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIt.expected.hs @@ -0,0 +1,11 @@ +module TIt where + +-- >>> "test" +-- >>> it +-- "test" +-- "test" + +-- >>> pure "test2" +-- >>> it +-- "test2" +-- "test2" diff --git a/plugins/hls-eval-plugin/test/testdata/TIt.hs b/plugins/hls-eval-plugin/test/testdata/TIt.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIt.hs @@ -0,0 +1,7 @@ +module TIt where + +-- >>> "test" +-- >>> it + +-- >>> pure "test2" +-- >>> it diff --git a/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.expected.hs b/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.expected.hs @@ -0,0 +1,9 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSections where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") + diff --git a/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.hs b/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLanguageOptionsTupleSections.hs @@ -0,0 +1,9 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSections where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") + diff --git a/plugins/hls-eval-plugin/test/testdata/TLastLine.expected.hs b/plugins/hls-eval-plugin/test/testdata/TLastLine.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLastLine.expected.hs @@ -0,0 +1,4 @@ +module TLastLine where + +-- >>> take 3 [1..] +-- [1,2,3] diff --git a/plugins/hls-eval-plugin/test/testdata/TLastLine.hs b/plugins/hls-eval-plugin/test/testdata/TLastLine.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLastLine.hs @@ -0,0 +1,3 @@ +module TLastLine where + +-- >>> take 3 [1..] diff --git a/plugins/hls-eval-plugin/test/testdata/TLocalImport.expected.hs b/plugins/hls-eval-plugin/test/testdata/TLocalImport.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLocalImport.expected.hs @@ -0,0 +1,9 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 +-- True + +tst' :: Eq a => a -> a -> Bool +tst' = Util.tst diff --git a/plugins/hls-eval-plugin/test/testdata/TLocalImport.hs b/plugins/hls-eval-plugin/test/testdata/TLocalImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLocalImport.hs @@ -0,0 +1,8 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 + +tst' :: Eq a => a -> a -> Bool +tst' = Util.tst diff --git a/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.expected.hs b/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.expected.hs @@ -0,0 +1,5 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a +-- 'a' diff --git a/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.hs b/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLocalImportInTest.hs @@ -0,0 +1,4 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.expected.hs b/plugins/hls-eval-plugin/test/testdata/TMulti.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.expected.hs @@ -0,0 +1,25 @@ +{- | Multi line comments are parsed correctly. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {- >>> 3+3 +6 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {-| >>> "NOT IGNORED" +"NOT IGNORED" +-} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs b/plugins/hls-eval-plugin/test/testdata/TMulti.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs @@ -0,0 +1,19 @@ +{- | Multi line comments are parsed correctly. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {- >>> 3+3 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {-| >>> "NOT IGNORED" -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" diff --git a/plugins/hls-eval-plugin/test/testdata/TMultiResult.expected.hs b/plugins/hls-eval-plugin/test/testdata/TMultiResult.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TMultiResult.expected.hs @@ -0,0 +1,13 @@ +module TMultiResult where +-- test multiline show instance (see #2907) + +data Multiline = M {l1 :: String, l2 :: String} deriving Read + +instance Show Multiline where + show m = "M {\n l1=" <> show (l1 m) <> ",\n l2=" <> show (l2 m) <> "\n}" + +-- >>> M "first line" "second line" +-- M { +-- l1="first line", +-- l2="second line" +-- } diff --git a/plugins/hls-eval-plugin/test/testdata/TMultiResult.hs b/plugins/hls-eval-plugin/test/testdata/TMultiResult.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TMultiResult.hs @@ -0,0 +1,9 @@ +module TMultiResult where +-- test multiline show instance (see #2907) + +data Multiline = M {l1 :: String, l2 :: String} deriving Read + +instance Show Multiline where + show m = "M {\n l1=" <> show (l1 m) <> ",\n l2=" <> show (l2 m) <> "\n}" + +-- >>> M "first line" "second line" diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.expected.hs b/plugins/hls-eval-plugin/test/testdata/TNested.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNested.expected.hs @@ -0,0 +1,15 @@ +module TNested () where +{- +>>> 54 +54 +{- +Nested +-} +-} + +{- +{- +>>> 42 +42 +-} +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.hs b/plugins/hls-eval-plugin/test/testdata/TNested.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNested.hs @@ -0,0 +1,13 @@ +module TNested () where +{- +>>> 54 +{- +Nested +-} +-} + +{- +{- +>>> 42 +-} +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.expected.hs b/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module TNoImplicitPrelude where + +import Data.List (unwords) +import Data.String (String) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.hs b/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNoImplicitPrelude.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module TNoImplicitPrelude where + +import Data.List (unwords) +import Data.String (String) + +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/plugins/hls-eval-plugin/test/testdata/TPlainComment.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPlainComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPlainComment.expected.hs @@ -0,0 +1,29 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlainComment where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" +-- "ab" + +{- Multi line comment + +>>> "b"++"c" +"bc" +-} + +{- >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five :: Integer +five = 5 diff --git a/plugins/hls-eval-plugin/test/testdata/TPlainComment.hs b/plugins/hls-eval-plugin/test/testdata/TPlainComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPlainComment.hs @@ -0,0 +1,26 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlainComment where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" + +{- Multi line comment + +>>> "b"++"c" +-} + +{- >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five :: Integer +five = 5 diff --git a/plugins/hls-eval-plugin/test/testdata/TPrelude.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPrelude.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPrelude.expected.hs @@ -0,0 +1,11 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +-- 20 +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/plugins/hls-eval-plugin/test/testdata/TPrelude.hs b/plugins/hls-eval-plugin/test/testdata/TPrelude.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPrelude.hs @@ -0,0 +1,10 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/plugins/hls-eval-plugin/test/testdata/TProperty.expected.hs b/plugins/hls-eval-plugin/test/testdata/TProperty.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TProperty.expected.hs @@ -0,0 +1,6 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l +-- +++ OK, passed 100 tests. + diff --git a/plugins/hls-eval-plugin/test/testdata/TProperty.hs b/plugins/hls-eval-plugin/test/testdata/TProperty.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TProperty.hs @@ -0,0 +1,5 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l + diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs @@ -0,0 +1,6 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test): +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/List.hs:1646:3 in base:GHC.List +-- errorEmptyList, called at libraries/base/GHC/List.hs:85:11 in base:GHC.List +-- badHead, called at libraries/base/GHC/List.hs:81:28 in base:GHC.List +-- head, called at :1:27 in interactive:Ghci2 +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc96.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc96.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc96.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/List.hs:1644:3 in base:GHC.List +-- errorEmptyList, called at libraries/base/GHC/List.hs:87:11 in base:GHC.List +-- badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List +-- head, called at :1:27 in interactive:Ghci2 +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/List.hs:1782:3 in base:GHC.List +-- errorEmptyList, called at libraries/base/GHC/List.hs:89:11 in base:GHC.List +-- badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List +-- head, called at :1:27 in interactive:Ghci2 +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs @@ -0,0 +1,4 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l diff --git a/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs b/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs @@ -0,0 +1,27 @@ +-- The default language extensions for the eval plugin are the same as those for ghci + +module TSameDefaultLanguageExtensionsAsGhci where + +{- +Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation. + +The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci. +(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483) + +It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only. +-} + + +-- ExtendedDefaultRules + +-- >>> [] +-- [] + +-- >>> reverse [] +-- [] + +-- NoMonomorphismRestriction + +-- >>> plus = (+) +-- >>> :t plus +-- plus :: Num a => a -> a -> a diff --git a/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs b/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs @@ -0,0 +1,24 @@ +-- The default language extensions for the eval plugin are the same as those for ghci + +module TSameDefaultLanguageExtensionsAsGhci where + +{- +Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation. + +The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci. +(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483) + +It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only. +-} + + +-- ExtendedDefaultRules + +-- >>> [] + +-- >>> reverse [] + +-- NoMonomorphismRestriction + +-- >>> plus = (+) +-- >>> :t plus diff --git a/plugins/hls-eval-plugin/test/testdata/TSectionEval.expected.hs b/plugins/hls-eval-plugin/test/testdata/TSectionEval.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSectionEval.expected.hs @@ -0,0 +1,17 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 +2 + +>>> 2+2 +4 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/plugins/hls-eval-plugin/test/testdata/TSectionEval.hs b/plugins/hls-eval-plugin/test/testdata/TSectionEval.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSectionEval.hs @@ -0,0 +1,15 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 + +>>> 2+2 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/plugins/hls-eval-plugin/test/testdata/TSetup.expected.hs b/plugins/hls-eval-plugin/test/testdata/TSetup.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSetup.expected.hs @@ -0,0 +1,12 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y +-- 33 + +-- >>> x*y +-- 242 diff --git a/plugins/hls-eval-plugin/test/testdata/TSetup.hs b/plugins/hls-eval-plugin/test/testdata/TSetup.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TSetup.hs @@ -0,0 +1,10 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y + +-- >>> x*y diff --git a/plugins/hls-eval-plugin/test/testdata/TTransitive.expected.hs b/plugins/hls-eval-plugin/test/testdata/TTransitive.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TTransitive.expected.hs @@ -0,0 +1,6 @@ +module TTransitive where + +import TLocalImport + +-- >>> tst' 11 11 +-- True diff --git a/plugins/hls-eval-plugin/test/testdata/TTransitive.hs b/plugins/hls-eval-plugin/test/testdata/TTransitive.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TTransitive.hs @@ -0,0 +1,5 @@ +module TTransitive where + +import TLocalImport + +-- >>> tst' 11 11 diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.expected.hs b/plugins/hls-eval-plugin/test/testdata/TUNPACK.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.expected.hs @@ -0,0 +1,14 @@ +{- | Won't panic on UNPACKs -} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" +-- "Yay! UNPACK pragma didn't do bad things!" diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs @@ -0,0 +1,13 @@ +{- | Won't panic on UNPACKs -} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" diff --git a/plugins/hls-eval-plugin/test/testdata/Util.hs b/plugins/hls-eval-plugin/test/testdata/Util.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/Util.hs @@ -0,0 +1,13 @@ +-- Used for testing local imports +module Util + ( tst + , a + , b + ) +where + +tst a b = a == b + +a = 'a' + +b = 'b' diff --git a/plugins/hls-eval-plugin/test/testdata/hie.yaml b/plugins/hls-eval-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "./" + component: "lib:test" diff --git a/plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs b/plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs @@ -0,0 +1,20 @@ +module InfoUtil + ( Eq + , Ord + , Foo (..) + , Bar (..) + , Baz + ) +where + +import Prelude (Eq, Ord) + +data Foo = Foo1 | Foo2 + deriving (Eq, Ord) + +data Bar = Bar1 | Bar2 | Bar3 + deriving (Eq, Ord) + +class Baz t +instance Baz Foo +instance Baz Bar diff --git a/plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal b/plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal @@ -0,0 +1,18 @@ +name: info-util +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + InfoUtil + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -0,0 +1,25 @@ +name: test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + TProperty + TPropertyError + TInfo + TInfoMany + TInfoBang + TInfoBangMany + TI_Info + + build-depends: base >= 4.7 && < 5, QuickCheck, info-util + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Ide.Plugin.ExplicitFixity(descriptor, Log) where + +import Control.DeepSeq +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Either.Extra +import Data.Hashable +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers, + pluginRules) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.Shake (addPersistentRule) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.LSP.Notifications (ghcideNotificationsPluginPriority) +import Development.IDE.Spans.AtPoint +import GHC.Generics (Generic) +import Ide.Plugin.Error +import Ide.Types hiding (pluginId) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides fixity information in hovers") + { pluginRules = fixityRule recorder + , pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover + -- Make this plugin has a lower priority than ghcide's plugin to ensure + -- type info display first. + , pluginPriority = ghcideNotificationsPluginPriority - 1 + } + +hover :: PluginMethodHandler IdeState Method_TextDocumentHover +hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = do + nfp <- getNormalizedFilePathE uri + runIdeActionE "ExplicitFixity" (shakeExtras state) $ do + (FixityMap fixmap, _) <- useWithStaleFastE GetFixity nfp + (HAR{hieAst}, mapping) <- useWithStaleFastE GetHieAst nfp + let ns = getNamesAtPoint hieAst pos mapping + fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns + pure $ maybeToNull $ toHover fs + where + toHover :: [(Name, Fixity)] -> Maybe Hover + toHover [] = Nothing + toHover fixities = + let -- Splicing fixity info + contents = T.intercalate "\n\n" $ fixityText <$> fixities + -- Append to the previous hover content + contents' = "\n" <> sectionSeparator <> contents + in Just $ Hover (InL (mkPlainText contents')) Nothing + + fixityText :: (Name, Fixity) -> T.Text + fixityText (name, Fixity _ precedence direction) = + printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" + +newtype FixityMap = FixityMap (M.Map Name Fixity) +instance Show FixityMap where + show _ = "FixityMap" + +instance NFData FixityMap where + rnf (FixityMap xs) = rnf xs + +instance NFData Fixity where + rnf = rwhnf + +newtype Log = LogShake Shake.Log + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +data GetFixity = GetFixity deriving (Show, Eq, Generic) + +instance Hashable GetFixity +instance NFData GetFixity + +type instance RuleResult GetFixity = FixityMap + +-- | Convert a HieAST to FixityTree with fixity info gathered +lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity) +lookupFixities hscEnv tcGblEnv names + = liftIO + $ fmap (fromMaybe M.empty . snd) + $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) + $ M.traverseMaybeWithKey (\_ v -> v) + $ M.fromSet lookupFixity names + where + lookupFixity name = do + f <- Util.handleGhcException + (const $ pure Nothing) + (Just <$> lookupFixityRn name) + if f == Just defaultFixity + then pure Nothing + else pure f + +fixityRule :: Recorder (WithPriority Log) -> Rules () +fixityRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do + HAR{refMap} <- use_ GetHieAst nfp + env <- hscEnv <$> use_ GhcSessionDeps nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates + tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp + fs <- lookupFixities env tcGblEnv (S.mapMonotonic (\(Right n) -> n) $ S.filter isRight $ M.keysSet refMap) + pure ([], Just (FixityMap fs)) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetFixity $ \_ -> pure $ Just (FixityMap M.empty, idDelta, Nothing) diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Data.Text as T +import Ide.Plugin.ExplicitFixity (Log, descriptor) +import System.FilePath +import Test.Hls + +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "explicit-fixity" + +main :: IO () +main = defaultTestRunner tests + +tests :: TestTree +tests = testGroup "Explicit fixity" + [ hoverTest "(++)" (Position 5 7) "infixr 5 `++`" + , hoverTest "($)" (Position 6 7) "infixr 0 `$`" + , hoverTest "(.)" (Position 7 7) "infixr 9 `.`" + , hoverTest "(+)" (Position 8 7) "infixl 6 `+`" + , hoverTest "(-)" (Position 9 8) "infixl 6 `-`" + , hoverTest "(<>)" (Position 10 7) "infixr 6 `<>`" + , hoverTest "(>>=)" (Position 11 7) "infixl 1 `>>=`" + , hoverTest "(>=>)" (Position 12 7) "infixr 1 `>=>`" + , hoverTest "elem" (Position 13 7) "infix 4 `elem`" + , hoverTest "on" (Position 14 7) "infixl 0 `on`" + , hoverTest "(||)" (Position 15 8) "infixr 2 `||`" + , hoverTest "mod" (Position 16 8) "infixl 7 `mod`" + , hoverTest "(**)" (Position 17 8) "infixr 8 `**`" + , hoverTest "(^)" (Position 18 8) "infixr 8 `^`" + , hoverTest "(<$)" (Position 19 8) "infixl 4 `<$`" + , hoverTest "seq" (Position 20 9) "infixr 0 `seq`" + , hoverTest "(<|>)" (Position 21 8) "infixl 3 `<|>`" + , hoverTest "fixity define" (Position 23 11) "infixr 7 `>>:`" + , hoverTest "record" (Position 28 10) "infix 9 `>>::`" + , hoverTest "wildcards1" (Position 30 5) "infixr 7 `>>:`" + , hoverTest "wildcards2" (Position 30 5) "infix 9 `>>::`" + , hoverTest "function" (Position 32 11) "infixl 1 `f`" + , hoverTest "signature" (Position 35 2) "infixr 9 `>>>:`" + , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`" + , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`" + -- Ensure that there is no one extra new line in import statement + , expectFail $ hoverTest "import" (Position 2 18) "Control.Monad***" + -- Known issue, See https://github.com/haskell/haskell-language-server/pull/2973/files#r916535742 + , expectFail $ hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`" + ] + +hoverTest :: TestName -> Position -> T.Text -> TestTree +hoverTest = hoverTest' "Hover.hs" +hoverTestImport :: TestName -> Position -> T.Text -> TestTree +hoverTestImport = hoverTest' "HoverImport.hs" + +hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree +hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc docName "haskell" + waitForKickDone + h <- getHover doc pos + case h of + Nothing -> liftIO $ assertFailure "No hover" + Just (Hover contents _) -> case contents of + InL (MarkupContent _ txt) -> do + liftIO + $ assertBool ("Failed to find `" <> T.unpack expected <> "` in hover message: " <> T.unpack txt) + $ expected `T.isInfixOf` txt + _ -> liftIO $ assertFailure "Unexpected content type" + closeDoc doc + +testDataDir :: FilePath +testDataDir = "plugins" "hls-explicit-fixity-plugin" "test" "testdata" diff --git a/plugins/hls-explicit-fixity-plugin/test/testdata/Hover.hs b/plugins/hls-explicit-fixity-plugin/test/testdata/Hover.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-fixity-plugin/test/testdata/Hover.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +module Hover where +import Control.Monad +import Data.Function (on) +import Control.Applicative ((<|>)) +f1 = (++) +f2 = ($) +f3 = (.) +f4 = (+) +f5 = 1 - 2 +f6 = (<>) +f7 = (>>=) +f8 = (>=>) +f9 = elem +f10 = on +f11 = (||) +f12 = mod +f13 = (**) +f14 = (^) +f15 = (<$) +f16 = seq +f17 = (<|>) + +infixr 7 >>: +infix 9 >>:: +data F = G + { (>>:) :: Int -> Int -> Int + , c :: Int + , (>>::) :: Char + } +f G{..} = undefined + +infixl 1 `f` + +infixr 9 >>>: +(>>>:) :: Int -> Int +(>>>:) x = 3 + +infixl 3 ~\: +(~\:) x y = 3 diff --git a/plugins/hls-explicit-fixity-plugin/test/testdata/HoverImport.hs b/plugins/hls-explicit-fixity-plugin/test/testdata/HoverImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-fixity-plugin/test/testdata/HoverImport.hs @@ -0,0 +1,5 @@ +module HoverImport where + +import Hover + +g = (>>>:) diff --git a/plugins/hls-explicit-fixity-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-fixity-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-fixity-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.ExplicitImports + ( descriptor + , descriptorForModules + , abbreviateImportTitle + , Log(..) + ) where + +import Control.DeepSeq +import Control.Lens ((&), (?~)) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as A (ToJSON (toJSON)) +import Data.Aeson.Types (FromJSON) +import qualified Data.IntMap as IM (IntMap, elems, + fromList, (!?)) +import Data.IORef (readIORef) +import qualified Data.Map.Strict as Map +import Data.Maybe (isNothing, mapMaybe) +import qualified Data.Set as S +import Data.String (fromString) +import qualified Data.Text as T +import Data.Traversable (for) +import qualified Data.Unique as U (hashUnique, + newUnique) +import Development.IDE hiding (pluginHandlers, + pluginRules) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding ((<+>)) +import Development.IDE.Graph.Classes +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (..), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (filterByRange) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.Plugin.Resolve +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server + +-- This plugin is named explicit-imports for historical reasons. Besides +-- providing code actions and lenses to make imports explicit it also provides +-- code actions and lens to refine imports. + +importCommandId :: CommandId +importCommandId = "ImportLensCommand" + +data Log + = LogShake Shake.Log + | LogWAEResponseError ResponseError + | forall a. (Pretty a) => LogResolve a + + +instance Pretty Log where + pretty = \case + LogShake logMsg -> pretty logMsg + LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> pretty rspErr + LogResolve msg -> pretty msg + +-- | The "main" function of a plugin +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder = + -- (almost) no one wants to see an explicit import list for Prelude + descriptorForModules recorder (/= moduleName pRELUDE) + +descriptorForModules + :: Recorder (WithPriority Log) + -> (ModuleName -> Bool) + -- ^ Predicate to select modules that will be annotated + -> PluginId + -> PluginDescriptor IdeState +descriptorForModules recorder modFilter plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + codeActionHandlers = mkCodeActionHandlerWithResolve resolveRecorder (codeActionProvider recorder) (codeActionResolveProvider recorder) + in (defaultPluginDescriptor plId "Provides a code action to make imports explicit") + { + -- This plugin provides a command handler + pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], + -- This plugin defines a new rule + pluginRules = minimalImportsRule recorder modFilter, + pluginHandlers = + -- This plugin provides code lenses + mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) + <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) + -- This plugin provides code actions + <> codeActionHandlers + + } + +-- | The actual command handler +runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData +runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do + wedit <- resolveWTextEdit ideState eird + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors + return $ InR Null + where logErrors (Left re@(ResponseError{})) = do + logWith recorder Error (LogWAEResponseError re) + pure () + logErrors (Right _) = pure () +runImportCommand _ _ _ rd = do + throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for command handler:" <> show rd) + + +-- | We provide two code lenses for imports. The first lens makes imports +-- explicit. For example, for the module below: +-- > import Data.List +-- > f = intercalate " " . sortBy length +-- the provider should produce one code lens associated to the import statement: +-- > import Data.List (intercalate, sortBy) +-- +-- The second one allows us to import functions directly from the original +-- module. For example, for the following import +-- > import Random.ReExporting.Module (liftIO) +-- the provider should produce one code lens associated to the import statement: +-- > Refine imports to import Control.Monad.IO.Class (liftIO) +lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let lens = [ generateLens _uri newRange int + | (range, int) <- forLens + , Just newRange <- [toCurrentRange pm range]] + pure $ InL lens + where -- because these are non resolved lenses we only need the range and a + -- unique id to later resolve them with. These are for both refine + -- import lenses and for explicit import lenses. + generateLens :: Uri -> Range -> Int -> CodeLens + generateLens uri range int = + CodeLens { _data_ = Just $ A.toJSON $ ResolveOne uri int + , _range = range + , _command = Nothing } + +lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeLensResolve +lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do + nfp <- getNormalizedFilePathE uri + (ImportActionsResult{forResolve}, _) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp + target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid + let updatedCodeLens = cl & L.command ?~ mkCommand plId target + pure updatedCodeLens + where mkCommand :: PluginId -> ImportEdit -> Command + mkCommand pId (ImportEdit{ieResType, ieText}) = + let -- The only new thing we need to provide to resolve a lens is the + -- title, as the unique Id is the same to resolve the lens title + -- as it is to apply the lens through a command. + -- The title is written differently depending on what type of lens + -- it is. + title ExplicitImport = abbreviateImportTitle ieText + title RefineImport = "Refine imports to " <> T.intercalate ", " (T.lines ieText) + in mkLspCommand pId importCommandId (title ieResType) (Just [A.toJSON rd]) +lensResolveProvider _ _ _ _ _ rd = do + throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for lens resolve handler: " <> show rd) + +-- |For explicit imports: If there are any implicit imports, provide both one +-- code action per import to make that specific import explicit, and one code +-- action to turn them all into explicit imports. For refine imports: If there +-- are any reexported imports, provide both one code action per import to refine +-- that specific import, and one code action to refine all imports. +codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult{forCodeActions}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp + newRange <- toCurrentRangeE pm range + let relevantCodeActions = filterByRange newRange forCodeActions + allExplicit = + [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ExplicitAll _uri) + -- We should only provide this code action if there are any code + -- of this type + | any (\x -> iaResType x == ExplicitImport) relevantCodeActions] + allRefine = + [InR $ mkCodeAction "Refine all imports" (Just $ A.toJSON $ RefineAll _uri) + -- We should only provide this code action if there are any code + -- of this type + | any (\x -> iaResType x == RefineImport) relevantCodeActions] + -- The only thing different in making the two types of code actions, is + -- the title. The actual resolve data type, ResolveOne is used by both + -- of them + toCodeAction uri (ImportAction _ int ExplicitImport) = + mkCodeAction "Make this import explicit" (Just $ A.toJSON $ ResolveOne uri int) + toCodeAction uri (ImportAction _ int RefineImport) = + mkCodeAction "Refine this import" (Just $ A.toJSON $ ResolveOne uri int) + pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit <> allRefine) + where mkCodeAction title data_ = + CodeAction + { _title = title + , _kind = Just CodeActionKind_QuickFix + , _command = Nothing + , _edit = Nothing + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _data_ = data_} + +codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeActionResolve +codeActionResolveProvider _ ideState _ ca _ rd = do + wedit <- resolveWTextEdit ideState rd + pure $ ca & L.edit ?~ wedit +-------------------------------------------------------------------------------- + +resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (LspT Config IO) WorkspaceEdit +-- Providing the edit for the command, or the resolve for the code action is +-- completely generic, as all we need is the unique id and the text edit. +resolveWTextEdit ideState (ResolveOne uri int) = do + nfp <- getNormalizedFilePathE uri + (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp + iEdit <- handleMaybe PluginStaleResolve $ forResolve IM.!? int + pure $ mkWorkspaceEdit uri [iEdit] pm +resolveWTextEdit ideState (ExplicitAll uri) = do + nfp <- getNormalizedFilePathE uri + (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp + let edits = [ ie | ie@ImportEdit{ieResType = ExplicitImport} <- IM.elems forResolve] + pure $ mkWorkspaceEdit uri edits pm +resolveWTextEdit ideState (RefineAll uri) = do + nfp <- getNormalizedFilePathE uri + (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp + let edits = [ re | re@ImportEdit{ieResType = RefineImport} <- IM.elems forResolve] + pure $ mkWorkspaceEdit uri edits pm +mkWorkspaceEdit :: Uri -> [ImportEdit] -> PositionMapping -> WorkspaceEdit +mkWorkspaceEdit uri edits pm = + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, mapMaybe toWEdit edits)] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + where toWEdit ImportEdit{ieRange, ieText} = + let newRange = toCurrentRange pm ieRange + in (\r -> TextEdit r ieText) <$> newRange + +data ImportActions = ImportActions + deriving (Show, Generic, Eq, Ord) + +instance Hashable ImportActions + +instance NFData ImportActions + +type instance RuleResult ImportActions = ImportActionsResult + +data ResultType = ExplicitImport | RefineImport + deriving Eq + +data ImportActionsResult = ImportActionsResult + { -- |For providing the code lenses we need to have a range, and a unique id + -- that is later resolved to the new text for each import. It is stored in + -- a list, because we always need to provide all the code lens in a file. + forLens :: [(Range, Int)] + -- |For the code actions we have the same data as for the code lenses, but + -- we store it in a RangeMap, because that allows us to filter on a specific + -- range with better performance, and code actions are almost always only + -- requested for a specific range + , forCodeActions :: RM.RangeMap ImportAction + -- |For resolve we have an intMap where for every previously provided unique id + -- we provide a textEdit to allow our code actions or code lens to be resolved + , forResolve :: IM.IntMap ImportEdit } + +-- |For resolving code lenses and code actions we need standard text edit stuff, +-- such as range and text, and then we need the result type, because we use this +-- for code lenses which need to create a appropriate title +data ImportEdit = ImportEdit { ieRange :: Range, ieText :: T.Text, ieResType :: ResultType} + +-- |The necessary data for providing code actions: the range, a unique ID for +-- later resolving the action, and the type of action for giving a proper name. +data ImportAction = ImportAction { iaRange :: Range, iaUniqueId :: Int, iaResType :: ResultType} + +instance Show ImportActionsResult where show _ = "" + +instance NFData ImportActionsResult where rnf = rwhnf + +data IAResolveData = ResolveOne + { uri :: Uri + , importId :: Int } + | ExplicitAll + { uri :: Uri } + | RefineAll + { uri :: Uri } + deriving (Generic, Show, A.ToJSON, FromJSON) + +exportedModuleStrings :: ParsedModule -> [String] +exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} + | Just export <- hsmodExports, + exports <- unLoc export + = map (T.unpack . printOutputable) exports +exportedModuleStrings _ = [] + +minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () +minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \ImportActions nfp -> runMaybeT $ do + -- Get the typechecking artifacts from the module + tmr <- MaybeT $ use TypeCheck nfp + -- We also need a GHC session with all the dependencies + hsc <- MaybeT $ use GhcSessionDeps nfp + + -- refine imports: 2 layer map ModuleName -> ModuleName -> [Avails] (exports) + import2Map <- do + -- first layer is from current(editing) module to its imports + ImportMap currIm <- MaybeT $ use GetImportMap nfp + for currIm $ \path -> do + -- second layer is from the imports of first layer to their imports + ImportMap importIm <- MaybeT $ use GetImportMap path + for importIm $ \imp_path -> do + imp_hir <- MaybeT $ use GetModIface imp_path + return $ mi_exports $ hirModIface imp_hir + + -- Use the GHC api to extract the "minimal" imports + locationImportWithMinimal <- MaybeT $ liftIO $ extractMinimalImports hsc tmr + + let minimalImportsResult = + [ (range, (printOutputable minImport, ExplicitImport)) + | (location, impDecl, minImport) <- locationImportWithMinimal + , not (isQualifiedImport impDecl) + , not (isExplicitImport impDecl) + , let L _ moduleName = ideclName impDecl + , modFilter moduleName + , let range = realSrcSpanToRange location] + + refineImportsResult = + [ (range, (T.intercalate "\n" + . map (printOutputable . constructImport origImport minImport) + . Map.toList + $ filteredInnerImports, RefineImport)) + -- for every minimal imports + | (location, origImport, minImport@(ImportDecl{ideclName = L _ mn})) <- locationImportWithMinimal + -- (almost) no one wants to see an refine import list for Prelude + , mn /= moduleName pRELUDE + -- we check for the inner imports + , Just innerImports <- [Map.lookup mn import2Map] + -- and only get those symbols used + , Just filteredInnerImports <- [filterByImport minImport innerImports] + -- if no symbols from this modules then don't need to generate new import + , not $ null filteredInnerImports + -- and then convert that to a Range + , let range = realSrcSpanToRange location + ] + uniqueAndRangeAndText <- liftIO $ for (minimalImportsResult ++ refineImportsResult) $ \rt -> do + u <- U.hashUnique <$> U.newUnique + pure (u, rt) + let rangeAndUnique = [ ImportAction r u rt | (u, (r, (_, rt))) <- uniqueAndRangeAndText ] + pure ImportActionsResult + { forLens = (\ImportAction{..} -> (iaRange, iaUniqueId)) <$> rangeAndUnique + , forCodeActions = RM.fromList iaRange rangeAndUnique + , forResolve = IM.fromList ((\(u, (r, (te, ty))) -> (u, ImportEdit r te ty)) <$> uniqueAndRangeAndText) } + +-------------------------------------------------------------------------------- + +-- | Use the ghc api to extract a minimal, explicit set of imports for this module +extractMinimalImports :: + HscEnvEq -> + TcModuleResult -> + IO (Maybe [(RealSrcSpan, ImportDecl GhcRn, ImportDecl GhcRn)]) +extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do + -- extract the original imports and the typechecking environment + let tcEnv = tmrTypechecked + (_, imports, _, _) = tmrRenamed + ParsedModule {pm_parsed_source = L loc _} = tmrParsed + emss = exportedModuleStrings tmrParsed + Just srcSpan <- pure $ realSpan loc + -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! + -- See https://github.com/haskell/haskell-language-server/issues/2079 + let notExportedImports = filter (notExported emss) imports + + -- GHC is secretly full of mutable state + gblElts <- liftIO $ readIORef (tcg_used_gres tcEnv) + + -- call findImportUsage does exactly what we need + -- GHC is full of treats like this + let usage = findImportUsage notExportedImports gblElts + (_, Just minimalImports) <- liftIO $ + initTcWithGbl (hscEnv hsc) tcEnv srcSpan $ getMinimalImports usage + + let minimalImportsMap = + Map.fromList + [ (realSrcSpanStart l, impDecl) + | L (locA -> RealSrcSpan l _) impDecl <- minimalImports + ] + results = + [ (location, imp, minImport) + | L (locA -> RealSrcSpan location _) imp <- imports + , Just minImport <- [Map.lookup (realSrcSpanStart location) minimalImportsMap]] + -- return both the original imports and the computed minimal ones + return results + where + notExported :: [String] -> LImportDecl GhcRn -> Bool + notExported [] _ = True + notExported exports (L _ ImportDecl{ideclName = L _ name}) = + not $ any (\e -> ("module " ++ moduleNameString name) == e) exports + +isExplicitImport :: ImportDecl GhcRn -> Bool +#if MIN_VERSION_ghc(9,5,0) +isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True +#else +isExplicitImport ImportDecl {ideclHiding = Just (False, _)} = True +#endif +isExplicitImport _ = False + +-- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things, +-- but at the moment I don't believe we know it. +-- 80 columns is traditional, but Haskellers tend to use longer lines (citation needed) and it's +-- probably not too bad if the lens is a *bit* longer than normal lines. +maxColumns :: Int +maxColumns = 120 + + +-- | The title of the command is ideally the minimal explicit import decl, but +-- we don't want to create a really massive code lens (and the decl can be extremely large!). +-- So we abbreviate it to fit a max column size, and indicate how many more items are in the list +-- after the abbreviation +abbreviateImportTitle :: T.Text -> T.Text +abbreviateImportTitle input = + let + -- For starters, we only want one line in the title + oneLineText = T.unwords $ T.lines input + -- Now, split at the max columns, leaving space for the summary text we're going to add + -- (conservatively assuming we won't need to print a number larger than 100) + (prefix, suffix) = T.splitAt (maxColumns - T.length (summaryText 100)) oneLineText + -- We also want to truncate the last item so we get a "clean" break, rather than half way through + -- something. The conditional here is just because 'breakOnEnd' doesn't give us quite the right thing + -- if there are actually no commas. + (actualPrefix, extraSuffix) = if T.count "," prefix > 0 then T.breakOnEnd "," prefix else (prefix, "") + actualSuffix = extraSuffix <> suffix + + -- The number of additional items is the number of commas+1 + numAdditionalItems = T.count "," actualSuffix + 1 + -- We want to make text like this: import Foo (AImport, BImport, ... (30 items)) + -- We also want it to look sensible if we end up splitting in the module name itself, + summaryText :: Int -> T.Text + summaryText n = " ... (" <> fromString (show n) <> " items)" + -- so we only add a trailing paren if we've split in the export list + suffixText = summaryText numAdditionalItems <> if T.count "(" prefix > 0 then ")" else "" + title = + -- If the original text fits, just use it + if T.length oneLineText <= maxColumns + then oneLineText + else actualPrefix <> suffixText + in title + +-------------------------------------------------------------------------------- + + +filterByImport :: ImportDecl GhcRn -> Map.Map ModuleName [AvailInfo] -> Maybe (Map.Map ModuleName [AvailInfo]) +#if MIN_VERSION_ghc(9,5,0) +filterByImport (ImportDecl{ideclImportList = Just (_, L _ names)}) +#else +filterByImport (ImportDecl{ideclHiding = Just (_, L _ names)}) +#endif + avails = + -- if there is a function defined in the current module and is used + -- i.e. if a function is not reexported but defined in current + -- module then this import cannot be refined + if importedNames `S.isSubsetOf` allFilteredAvailsNames + then Just res + else Nothing + where importedNames = S.fromList $ map (ieName . unLoc) names + res = flip Map.filter avails $ \a -> + any (`S.member` importedNames) + $ concatMap + getAvailNames + a + allFilteredAvailsNames = S.fromList + $ concatMap getAvailNames + $ mconcat + $ Map.elems res +filterByImport _ _ = Nothing + +constructImport :: ImportDecl GhcRn -> ImportDecl GhcRn -> (ModuleName, [AvailInfo]) -> ImportDecl GhcRn +#if MIN_VERSION_ghc(9,5,0) +constructImport ImportDecl{ideclQualified = qualified, ideclImportList = origHiding} imd@ImportDecl{ideclImportList = Just (hiding, L _ names)} +#else +constructImport ImportDecl{ideclQualified = qualified, ideclHiding = origHiding} imd@ImportDecl{ideclHiding = Just (hiding, L _ names)} +#endif + (newModuleName, avails) = imd + { ideclName = noLocA newModuleName +#if MIN_VERSION_ghc(9,5,0) + , ideclImportList = if isNothing origHiding && qualified /= NotQualified + then Nothing + else Just (hiding, noLocA newNames) +#else + , ideclHiding = if isNothing origHiding && qualified /= NotQualified + then Nothing + else Just (hiding, noLocA newNames) +#endif + } + where newNames = filter (\n -> any (n `containsAvail`) avails) names + -- Check if a name is exposed by AvailInfo (the available information of a module) + containsAvail :: LIE GhcRn -> AvailInfo -> Bool + containsAvail name avail = + any (\an -> printOutputable an == (printOutputable . ieName . unLoc $ name)) + $ getAvailNames avail + +constructImport _ lim _ = lim + +getAvailNames :: AvailInfo -> [Name] +getAvailNames = +#if MIN_VERSION_ghc(9,7,0) + availNames +#else + availNamesWithSelectors +#endif diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Main + ( main + ) where + +import Control.Lens ((^.)) +import Data.Either.Extra +import Data.Foldable (find) +import Data.Row ((.+), (.==)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Traversable (for) +import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import System.FilePath (()) +import Test.Hls + +explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log +explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports" + +main :: IO () +main = defaultTestRunner $ testGroup "import-actions" + [testGroup + "Refine Imports" + [ codeActionGoldenTest "RefineWithOverride" 3 1 + , codeLensGoldenTest isRefineImports "RefineUsualCase" 1 + , codeLensGoldenTest isRefineImports "RefineQualified" 0 + , codeLensGoldenTest isRefineImports "RefineQualifiedExplicit" 0 + ], + testGroup + "Make imports explicit" + [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0 + , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0 + , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0 + , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0 + , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 + , codeActionBreakFile "ExplicitBreakFile" 4 0 + , codeActionStaleAction "ExplicitStaleAction" 4 0 + , testCase "No CodeAction when exported" $ + runSessionWithServer def explicitImportsPlugin testDataDir $ do + doc <- openDoc "ExplicitExported.hs" "haskell" + action <- getCodeActions doc (pointRange 3 0) + liftIO $ action @?= [] + , testCase "No CodeLens when exported" $ + runSessionWithServer def explicitImportsPlugin testDataDir $ do + doc <- openDoc "ExplicitExported.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ lenses @?= [] + , testGroup "Title abbreviation" + [ testCase "not abbreviated" $ + let i = "import " <> T.replicate 70 "F" <> " (Athing, Bthing, Cthing)" + in ExplicitImports.abbreviateImportTitle i @?= i + , testCase "abbreviated in module name" $ + let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)" + o = "import " <> T.replicate 97 "F" <> " ... (3 items)" + in ExplicitImports.abbreviateImportTitle i @?= o + , testCase "abbreviated in import list" $ + let i = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)" + o = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, ... (3 items))" + in ExplicitImports.abbreviateImportTitle i @?= o + -- This one breaks earlier in the same import item, but still splits the list in the same place + , testCase "abbreviated in import list (slightly shorter module)" $ + let i = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)" + o = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, ... (3 items))" + in ExplicitImports.abbreviateImportTitle i @?= o + -- This one breaks later in the same import item, but still splits the list in the same place + , testCase "abbreviated in import list (slightly longer module)" $ + let i = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)" + o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))" + in ExplicitImports.abbreviateImportTitle i @?= o + ] + ]] + +-- code action tests + +codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionBreakFile :: FilePath -> Int -> Int -> TestTree +codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do + _ <- getCodeLenses doc + changeDoc doc [edit] + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 29 + .+ #rangeLength .== Nothing + .+ #text .== "x" + +codeActionStaleAction :: FilePath -> Int -> Int -> TestTree +codeActionStaleAction fp l c = goldenWithImportActions " code action" fp codeActionResolveCaps $ \doc -> do + _ <- waitForDiagnostics + actions <- getCodeActions doc (pointRange l c) + changeDoc doc [edit] + _ <- waitForDiagnostics + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> + maybeResolveCodeAction x >>= + \case Just _ -> liftIO $ assertFailure "Code action still valid" + Nothing -> pure () + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0) + .+ #rangeLength .== Nothing + .+ #text .== "\ntesting = undefined" + +codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction) +maybeResolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + let resolved = resolveResponse ^. L.result + pure $ eitherToMaybe resolved + +caTitle :: (Command |? CodeAction) -> Maybe Text +caTitle (InR CodeAction {_title}) = Just _title +caTitle _ = Nothing + +-- code lens tests + +codeLensGoldenTest :: (CodeLens -> Bool) -> FilePath -> Int -> TestTree +codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoResolveCaps $ \doc -> do + codeLenses <- getCodeLenses doc + resolvedCodeLenses <- for codeLenses resolveCodeLens + (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i) + executeCmd c + +notRefineImports :: CodeLens -> Bool +notRefineImports (CodeLens _ (Just (Command text _ _)) _) + | "Refine imports to" `T.isPrefixOf` text = False +notRefineImports _ = True + +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + -- liftIO $ print _resp + return () + +-- helpers + +goldenWithImportActions :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithImportActions title fp caps = goldenWithHaskellAndCaps def caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" + +testDataDir :: String +testDataDir = "plugins" "hls-explicit-imports-plugin" "test" "testdata" + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) + +------------------------------------------------------------------------------- +-- code action tests + +codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionGoldenTest fp l c = goldenWithImportActions "" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Refine all imports") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +isRefineImports :: CodeLens -> Bool +isRefineImports (CodeLens _ (Just (Command txt _ _)) _) + | "Refine imports to" `T.isInfixOf` txt = True +isRefineImports _ = False diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitA.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitA.hs @@ -0,0 +1,7 @@ +module ExplicitA where + +a1 :: String +a1 = "a1" + +a2 :: String +a2 = "a2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitB.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitB.hs @@ -0,0 +1,7 @@ +module ExplicitB where + +b1 :: String +b1 = "b1" + +b2 :: String +b2 = "b2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module ExplicitBreakFile whexe + +import ExplicitA ( a1 ) + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitBreakFile.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module ExplicitBreakFile where + +import ExplicitA + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitExported.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitExported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitExported.hs @@ -0,0 +1,6 @@ +module ExplicitExported (module ExplicitA) where + +import ExplicitA + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.expected.hs @@ -0,0 +1,7 @@ +module ExplicitOnlyThis where + +import ExplicitA ( a1 ) +import ExplicitB + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitOnlyThis.hs @@ -0,0 +1,7 @@ +module ExplicitOnlyThis where + +import ExplicitA +import ExplicitB + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.expected.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} +module ExplicitStaleAction where + +import ExplicitA + +main = putStrLn $ "hello " ++ a1 + +testing = undefined diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitStaleAction.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module ExplicitStaleAction where + +import ExplicitA + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.expected.hs @@ -0,0 +1,6 @@ +module ExplicitUsualCase where + +import ExplicitA ( a1 ) + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/ExplicitUsualCase.hs @@ -0,0 +1,6 @@ +module ExplicitUsualCase where + +import ExplicitA + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineA.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineA.hs @@ -0,0 +1,7 @@ +module RefineA + ( module RefineB + , module RefineC + ) where + +import RefineB +import RefineC diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineB.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineB.hs @@ -0,0 +1,7 @@ +module RefineB where + +b1 :: String +b1 = "b1" + +b2 :: String +b2 = "b2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineC.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineC.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineC.hs @@ -0,0 +1,4 @@ +module RefineC where + +c1 :: String +c1 = "c1" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineD.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineD.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineD.hs @@ -0,0 +1,7 @@ +module RefineD (module RefineE, module RefineD) where + +import RefineE hiding (e1) +import qualified RefineE + +e1 :: String +e1 = RefineE.e1 <> " but overrided" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineE.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineE.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineE.hs @@ -0,0 +1,7 @@ +module RefineE where + +e1 :: String +e1 = "e1" + +e2 :: String +e2 = "e2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineF.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineF.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineF.hs @@ -0,0 +1,7 @@ +module RefineF (module RefineF, module RefineG) where + +import RefineG + +f1 :: String +f1 = "f1" + diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineG.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineG.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineG.hs @@ -0,0 +1,4 @@ +module RefineG where + +g1 :: String +g1 = "g1" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.expected.hs @@ -0,0 +1,11 @@ +module Main where + +import qualified RefineB as RA +import qualified RefineC as RA +import RefineD +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [RA.b1, RA.c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualified.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified RefineA as RA +import RefineD +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [RA.b1, RA.c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.expected.hs @@ -0,0 +1,11 @@ +module Main where + +import qualified RefineB as RA ( b1 ) +import qualified RefineC as RA ( c1 ) +import RefineD +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [RA.b1, RA.c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineQualifiedExplicit.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified RefineA as RA (b1, c1) +import RefineD +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [RA.b1, RA.c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.expected.hs @@ -0,0 +1,10 @@ +module Main where + +import RefineA +import RefineE ( e2 ) +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [b1, c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineUsualCase.hs @@ -0,0 +1,10 @@ +module Main where + +import RefineA +import RefineD +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [b1, c1, e2] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.expected.hs @@ -0,0 +1,12 @@ +module Main where + +import RefineB ( b1 ) +import RefineC ( c1 ) +import RefineD +import RefineF +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [b1, c1, e1, f1, g1] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.hs b/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/RefineWithOverride.hs @@ -0,0 +1,11 @@ +module Main where + +import RefineA +import RefineD +import RefineF +import Data.List (intercalate) + +main :: IO () +main = putStrLn + $ "hello " + <> intercalate ", " [b1, c1, e1, f1, g1] diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -0,0 +1,20 @@ +cradle: + direct: + arguments: + - ExplicitOnlyThis.hs + - ExplicitStaleAction.hs + - ExplicitUsualCase.hs + - ExplicitExported.hs + - ExplicitA.hs + - ExplicitB.hs + - RefineUsualCase.hs + - RefineQualified.hs + - RefineQualifiedExplicit.hs + - RefineWithOverride.hs + - RefineA.hs + - RefineB.hs + - RefineC.hs + - RefineD.hs + - RefineE.hs + - RefineF.hs + - RefineG.hs diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.ExplicitFields + ( descriptor + , Log + ) where + +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Maybe +import Data.Aeson (toJSON) +import Data.Generics (GenericQ, everything, + everythingBut, extQ, mkQ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, + maybeToList) +import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) + +import Control.Monad (replicateM) +import Development.IDE (IdeState, Pretty (..), Range, + Recorder (..), Rules, + WithPriority (..), + defineNoDiagnostics, + realSrcSpanToRange, viaShow) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsExpansion (HsExpanded), + HsExpr (XExpr), + HsRecFields (..), LPat, + Outputable, getLoc, + recDotDot, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + HsRecField, LHsExpr, + LocatedA, Name, Pass (..), + Pat (..), RealSrcSpan, + UniqFM, conPatDetails, + emptyUFM, hfbPun, hfbRHS, + hs_valds, lookupUFM, + mapConPatDetail, mapLoc, + pattern RealSrcSpan, + plusUFM_C, unitUFM) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, + logWith, (<+>)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + ResolveFunction, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), + CodeActionParams (..), + Command, TextEdit (..), + WorkspaceEdit (WorkspaceEdit), + type (|?) (InL, InR)) + + +data Log + = LogShake Shake.Log + | LogCollectedRecords [RecordInfo] + | LogRenderedRecords [TextEdit] + | forall a. (Pretty a) => LogResolve a + + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs + LogRenderedRecords recs -> "Rendered records:" <+> viaShow recs + LogResolve msg -> pretty msg + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit") + { pluginHandlers = caHandlers + , pluginCommands = carCommands + , pluginRules = collectRecordsRule recorder *> collectNamesRule + } + +codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do + nfp <- getNormalizedFilePathE (docId ^. L.uri) + CRR {crCodeActions, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- All we need to build a code action is the list of extensions, and a int to + -- allow us to resolve it later. + let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) + pure $ InL actions + where + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" + , _kind = Just CodeActionKind_RefactorRewrite + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Nothing + , _command = Nothing + , _data_ = Just $ toJSON uid + } + +codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve +codeActionResolveProvider ideState pId ca uri uid = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId ideState nfp + CRR {crCodeActionResolve, nameMap, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- If we are unable to find the unique id in our IntMap of records, it means + -- that this resolve is stale. + record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve + -- We should never fail to render + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record + let edits = [rendered] + <> maybeToList (pragmaEdit enabledExtensions pragma) + pure $ ca & L.edit ?~ mkWorkspaceEdit edits + where + mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit + mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing + pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit + pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns + +collectRecordsRule :: Recorder (WithPriority Log) -> Rules () +collectRecordsRule recorder = + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + (CNR nameMap) <- useMT CollectNames nfp + let recs = getRecords tmr + logWith recorder Debug (LogCollectedRecords recs) + -- We want a list of unique numbers to link our the original code action we + -- give out, with the actual record info that we resolve it to. + uniques <- liftIO $ replicateM (length recs) (hashUnique <$> newUnique) + let recsWithUniques = zip uniques recs + -- For creating the code actions, a RangeMap of unique ids + crCodeActions = RangeMap.fromList' (toRangeAndUnique <$> recsWithUniques) + -- For resolving the code actions, a IntMap which links the unique id to + -- the relevant record info. + crCodeActionResolve = IntMap.fromList recsWithUniques + enabledExtensions = getEnabledExtensions tmr + pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} + where + getEnabledExtensions :: TcModuleResult -> [Extension] + getEnabledExtensions = getExtensions . tmrParsed + toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) + +getRecords :: TcModuleResult -> [RecordInfo] +getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = + collectRecords valBinds + +collectNamesRule :: Rules () +collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + pure (CNR (getNames tmr)) + +-- | Collects all 'Name's of a given source file, to be used +-- in the variable usage analysis. +getNames :: TcModuleResult -> UniqFM Name [Name] +getNames (tmrRenamed -> (group,_,_,_)) = collectNames group + +data CollectRecords = CollectRecords + deriving (Eq, Show, Generic) + +instance Hashable CollectRecords +instance NFData CollectRecords + +-- |The result of our map, this record includes everything we need to provide +-- code actions and resolve them later +data CollectRecordsResult = CRR + { -- |For providing the code action we need the unique id (Int) in a RangeMap + crCodeActions :: RangeMap Int + -- |For resolving the code action we need to link the unique id we + -- previously gave out with the record info that we use to make the edit + -- with. + , crCodeActionResolve :: IntMap.IntMap RecordInfo + -- |The name map allows us to prune unused record fields (some of the time) + , nameMap :: UniqFM Name [Name] + -- |We need to make sure NamedFieldPuns is enabled, if it's not we need to + -- add that to the text edit. (In addition we use it in creating the code + -- action title) + , enabledExtensions :: [Extension] + } + deriving (Generic) + +instance NFData CollectRecordsResult +instance NFData RecordInfo + +instance Show CollectRecordsResult where + show _ = "" + +type instance RuleResult CollectRecords = CollectRecordsResult + +data CollectNames = CollectNames + deriving (Eq, Show, Generic) + +instance Hashable CollectNames +instance NFData CollectNames + +data CollectNamesResult = CNR (UniqFM Name [Name]) + deriving (Generic) + +instance NFData CollectNamesResult + +instance Show CollectNamesResult where + show _ = "" + +type instance RuleResult CollectNames = CollectNamesResult + +data RecordInfo + = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) + | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + deriving (Generic) + +instance Pretty RecordInfo where + pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) + pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) + +recordInfoToRange :: RecordInfo -> Range +recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss +recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss + +renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit +renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr + +-- | Checks if a 'Name' is referenced in the given map of names. The +-- 'hasNonBindingOcc' check is necessary in order to make sure that only the +-- references at the use-sites are considered (i.e. the binding occurence +-- is excluded). For more information regarding the structure of the map, +-- refer to the documentation of 'collectNames'. +referencedIn :: Name -> UniqFM Name [Name] -> Bool +referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name + where + hasNonBindingOcc :: [Name] -> Bool + hasNonBindingOcc = (> 1) . length + +-- Default to leaving the element in if somehow a name can't be extracted (i.e. +-- `getName` returns `Nothing`). +filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] +filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + +preprocessRecordPat + :: p ~ GhcPass 'Renamed + => UniqFM Name [Name] + -> HsRecFields p (LPat p) + -> HsRecFields p (LPat p) +preprocessRecordPat = preprocessRecord (getFieldName . unLoc) + where + getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing + +-- No need to check the name usage in the record construction case +preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg +preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM + +-- This function does two things: +-- 1) Tweak the AST type so that the pretty-printed record is in the +-- expanded form +-- 2) Determine the unused record fields so that they are filtered out +-- of the final output +-- +-- Regarding first point: +-- We make use of the `Outputable` instances on AST types to pretty-print +-- the renamed and expanded records back into source form, to be substituted +-- with the original record later. However, `Outputable` instance of +-- `HsRecFields` does smart things to print the records that originally had +-- wildcards in their original form (i.e. with dots, without field names), +-- even after the wildcard is removed by the renamer pass. This is undesirable, +-- as we want to print the records in their fully expanded form. +-- Here `rec_dotdot` is set to `Nothing` so that fields are printed without +-- such post-processing. +preprocessRecord + :: p ~ GhcPass c + => (LocatedA (HsRecField p arg) -> Maybe Name) + -> UniqFM Name [Name] + -> HsRecFields p arg + -> HsRecFields p arg +preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } + where + no_pun_count = fromMaybe (length (rec_flds flds)) (recDotDot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be + -- left as is, hence the split. + (no_puns, puns) = splitAt no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + -- Unused fields are filtered out so that they don't end up in the expanded + -- form. + punsUsed = filterReferenced getName names puns' + rec_flds' = no_puns <> punsUsed + +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat names = fmap printOutputable . mapConPatDetail (\case + RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) + _ -> Nothing) + +showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text +showRecordCon expr@(RecordCon _ _ flds) = + Just $ printOutputable $ + expr { rcon_flds = preprocessRecordCon flds } +showRecordCon _ = Nothing + +collectRecords :: GenericQ [RecordInfo] +collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons) + +-- | Collect 'Name's into a map, indexed by the names' unique identifiers. +-- The 'Eq' instance of 'Name's makes use of their unique identifiers, hence +-- any 'Name' referring to the same entity is considered equal. In effect, +-- each individual list of names contains the binding occurrence, along with +-- all the occurrences at the use-sites (if there are any). +-- +-- @UniqFM Name [Name]@ is morally the same as @Map Unique [Name]@. +-- Using 'UniqFM' gains us a bit of performance (in theory) since it +-- internally uses 'IntMap'. More information regarding 'UniqFM' can be found in +-- the GHC source. +collectNames :: GenericQ (UniqFM Name [Name]) +collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) + +getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +-- When we stumble upon an occurrence of HsExpanded, we only want to follow a +-- single branch. We do this here, by explicitly returning occurrences from +-- traversing the original branch, and returning True, which keeps syb from +-- implicitly continuing to traverse. In addition, we have to return a list, +-- because there is a possibility that there were be more than one result per +-- branch + +getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +getRecCons e@(unLoc -> RecordCon _ _ flds) + | isJust (rec_dotdot flds) = (mkRecInfo e, False) + where + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo expr = + [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] +getRecCons _ = ([], False) + +getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) + | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) + where + mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo pat = + [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] +getRecPatterns _ = ([], False) + + diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( main ) where + +import Data.Either (rights) +import qualified Data.Text as T +import qualified Ide.Plugin.ExplicitFields as ExplicitFields +import System.FilePath ((<.>), ()) +import Test.Hls + +main :: IO () +main = defaultTestRunner test + +plugin :: PluginTestDescriptor ExplicitFields.Log +plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" + +test :: TestTree +test = testGroup "explicit-fields" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 + , mkTest "Unused2" "Unused2" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 14 10 14 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + ] + +mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestNoAction title fp x1 y1 x2 y2 = + testCase title $ + runSessionWithServer def plugin (testDataDir "noop") $ do + doc <- openDoc (fp <.> "hs") "haskell" + actions <- getExplicitFieldsActions doc x1 y1 x2 y2 + liftIO $ actions @?= [] + +mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestWithCount cnt title fp x1 y1 x2 y2 = + goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 + liftIO $ length acts @?= cnt + executeCodeAction act + +mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTest = mkTestWithCount 1 + +getExplicitFieldsActions + :: TextDocumentIdentifier + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getExplicitFieldsActions doc x1 y1 x2 y2 = + findExplicitFieldsAction <$> getAndResolveCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +findExplicitFieldsAction :: [a |? CodeAction] -> [CodeAction] +findExplicitFieldsAction = filter isExplicitFieldsCodeAction . rights . map toEither + +isExplicitFieldsCodeAction :: CodeAction -> Bool +isExplicitFieldsCodeAction CodeAction {_title} = + "Expand record wildcard" `T.isPrefixOf` _title + +testDataDir :: FilePath +testDataDir = "plugins" "hls-explicit-record-fields-plugin" "test" "testdata" diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Construction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {foo, bar, baz} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Construction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {..} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +myRecExample = MyRec 5 + +convertMe :: Int +convertMe = + if (let MyRec {foo} = myRecExample + in foo) then 1 else 2 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +myRecExample = MyRec 5 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + in foo) then 1 else 2 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +data YourRec = YourRec + { bar :: Int } + +myRecExample = MyRec 5 + +yourRecExample = YourRec 3 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {bar} = yourRecExample + in bar) then 1 else 2 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +data YourRec = YourRec + { bar :: Int } + +myRecExample = MyRec 5 + +yourRecExample = YourRec 3 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {..} = yourRecExample + in bar) then 1 else 2 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Mixed where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + , quux :: Double + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar = bar', baz} = show foo ++ show bar' ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Mixed where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + , quux :: Double + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar = bar', ..} = show foo ++ show bar' ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Unused where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar} = show foo ++ show bar diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Unused where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = show foo ++ show bar diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Unused2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar} = let baz = "baz" in show foo ++ show bar ++ baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Unused2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = let baz = "baz" in show foo ++ show bar ++ baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WildcardOnly where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module WildcardOnly where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithExplicitBind where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', bar, baz} = show foo' ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module WithExplicitBind where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', ..} = show foo' ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithPun where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithPun where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, ..} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: []}} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Haskell2010 #-} + +module ExplicitBinds where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', bar = bar', baz = baz'} = show foo' ++ show bar' ++ show baz' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Haskell2010 #-} + +module Infix where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + } + +convertMe :: MyRec -> String +convertMe (foo' `MyRec` bar') = show foo' ++ show bar' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Haskell2010 #-} + +module Prefix where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + } + +convertMe :: MyRec -> String +convertMe (foo' `MyRec` bar') = show foo' ++ show bar' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Puns where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Floskell + ( descriptor + , provider + ) where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Development.IDE hiding (pluginHandlers) +import Floskell +import Ide.Plugin.Error +import Ide.PluginUtils +import Ide.Types +import Language.LSP.Protocol.Types + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers provider + } + where + desc = "Provides formatting of Haskell files via floskell. Built with floskell-" <> VERSION_floskell + +-- --------------------------------------------------------------------- + +-- | Format provider of Floskell. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: FormattingHandler IdeState +provider _ideState _token typ contents fp _ = do + let file = fromNormalizedFilePath fp + config <- liftIO $ findConfigOrDefault file + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) + result = reformat config (Just file) $ TL.fromStrict selectedContents + case result of + Left err -> throwError $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err + Right new -> pure $ InL [TextEdit range $ TL.toStrict new] + +-- | Find Floskell Config, user and system wide or provides a default style. +-- Every directory of the filepath will be searched to find a user configuration. +-- Also looks into places such as XDG_CONFIG_DIRECTORY. +-- This function may not throw an exception and returns a default config. +findConfigOrDefault :: FilePath -> IO AppConfig +findConfigOrDefault file = do + mbConf <- findAppConfigIn file + case mbConf of + Just confFile -> readAppConfig confFile + Nothing -> + let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles) + in pure $ defaultAppConfig { appStyle = gibiansky } + +-- --------------------------------------------------------------------- diff --git a/plugins/hls-floskell-plugin/test/Main.hs b/plugins/hls-floskell-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/test/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import qualified Ide.Plugin.Floskell as Floskell +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +floskellPlugin :: PluginTestDescriptor () +floskellPlugin = mkPluginTestDescriptor' Floskell.descriptor "floskell" + +tests :: TestTree +tests = testGroup "floskell" + [ goldenWithFloskell "formats a document" "Floskell" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) + + , goldenWithFloskell "formats a range" "Floskell" "formatted_range" $ \doc -> do + let range = Range (Position 1 0) (Position 4 22) + formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range + ] + +goldenWithFloskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithFloskell title path desc = goldenWithHaskellDocFormatter def floskellPlugin "floskell" def title testDataDir path desc "hs" + +testDataDir :: FilePath +testDataDir = "plugins" "hls-floskell-plugin" "test" "testdata" diff --git a/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_document.hs b/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_document.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_document.hs @@ -0,0 +1,17 @@ +module Floskell where + +import Data.List +import Prelude +import Data.Int + +foo :: Int -> Int +foo 3 = 2 +foo x = x + +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz { a :: Int, b :: String } + diff --git a/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_range.hs b/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_range.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/test/testdata/Floskell.formatted_range.hs @@ -0,0 +1,14 @@ +module Floskell where +import Data.List +import Prelude +import Data.Int +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz { a :: Int, b :: String } + diff --git a/plugins/hls-floskell-plugin/test/testdata/Floskell.hs b/plugins/hls-floskell-plugin/test/testdata/Floskell.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/test/testdata/Floskell.hs @@ -0,0 +1,15 @@ +module Floskell where +import Data.List + +import Prelude +import Data.Int +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz { a :: Int, b :: String } + diff --git a/plugins/hls-floskell-plugin/test/testdata/hie.yaml b/plugins/hls-floskell-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-floskell-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Fourmolu ( + descriptor, + provider, + LogEvent, +) where + +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad (guard) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Bifunctor (bimap) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.GHC.Compat as Compat hiding (Cpp, Warning, + hang, vcat) +import qualified Development.IDE.GHC.Compat.Util as S +import GHC.LanguageExtensions.Type (Extension (Cpp)) +import Ide.Plugin.Error +import Ide.Plugin.Properties +import Ide.PluginUtils (makeDiffTextEdit) +import Ide.Types +import Language.LSP.Protocol.Lens (HasTabSize (tabSize)) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server hiding (defaultConfig) +import Ormolu +import Ormolu.Config +import System.Exit +import System.FilePath +import System.Process.Run (cwd, proc) +import System.Process.Text (readCreateProcessWithExitCode) +import Text.Read (readMaybe) + +descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers $ provider recorder plId + , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties} + } + where + desc = "Provides formatting of Haskell files via fourmolu. Built with fourmolu-" <> VERSION_fourmolu + +properties :: Properties '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString] +properties = + emptyProperties + & defineStringProperty + #path + "Set path to executable (for \"external\" mode)." + "fourmolu" + & defineBooleanProperty + #external + "Call out to an external \"fourmolu\" executable, rather than using the bundled library." + False + +provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState +provider recorder plId ideState token typ contents fp fo = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do + fileOpts <- + maybe [] (convertDynFlags . hsc_dflags . hscEnv) + <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp) + useCLI <- liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #external plId properties + fourmoluExePath <- fmap T.unpack $ liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #path plId properties + if useCLI + then ExceptT . liftIO $ + handle @IOException (pure . Left . PluginInternalError . T.pack . show) $ + runExceptT (cliHandler fourmoluExePath fileOpts) + else do + logWith recorder Debug $ LogCompiledInVersion VERSION_fourmolu + FourmoluConfig{..} <- + liftIO (loadConfigFile fp') >>= \case + ConfigLoaded file opts -> do + logWith recorder Info $ ConfigPath file + pure opts + ConfigNotFound searchDirs -> do + logWith recorder Info $ NoConfigPath searchDirs + pure emptyConfig + ConfigParseError f err -> do + lift $ sendNotification SMethod_WindowShowMessage $ + ShowMessageParams + { _type_ = MessageType_Error + , _message = errorMessage + } + throwError $ PluginInternalError errorMessage + where + errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (show err) + + let config = +#if MIN_VERSION_fourmolu(0,13,0) + refineConfig ModuleSource Nothing Nothing Nothing +#endif + defaultConfig + { cfgDynOptions = map DynOption fileOpts + , cfgFixityOverrides = cfgFileFixities + , cfgRegion = region + , cfgDebug = False + , cfgPrinterOpts = resolvePrinterOpts [lspPrinterOpts, cfgFilePrinterOpts] + } + ExceptT . liftIO $ + bimap (PluginInternalError . T.pack . show) (InL . makeDiffTextEdit contents) + <$> try @OrmoluException (ormolu config fp' contents) + where + fp' = fromNormalizedFilePath fp + title = "Formatting " <> T.pack (takeFileName fp') + lspPrinterOpts = mempty{poIndentation = Just $ fromIntegral $ fo ^. tabSize} + region = case typ of + FormatText -> + RegionIndices Nothing Nothing + FormatRange (Range (Position sl _) (Position el _)) -> + RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1) + cliHandler :: FilePath -> [String] -> ExceptT PluginError IO ([TextEdit] |? Null) + cliHandler path fileOpts = do + CLIVersionInfo{noCabal} <- do -- check Fourmolu version so that we know which flags to use + (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc path ["-v"] ) "" + let version = do + guard $ exitCode == ExitSuccess + "fourmolu" : v : _ <- pure $ T.words out + traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v + case version of + Just v -> do + logWith recorder Debug $ LogExternalVersion v + pure CLIVersionInfo + { noCabal = v >= [0, 7] + } + Nothing -> do + logWith recorder Debug $ LogExternalVersion [] + logWith recorder Warning $ NoVersion out + pure CLIVersionInfo + { noCabal = True + } + (exitCode, out, err) <- -- run Fourmolu + liftIO $ readCreateProcessWithExitCode + ( proc path $ + map ("-o" <>) fileOpts + <> mwhen noCabal ["--no-cabal"] + <> catMaybes + [ ("--start-line=" <>) . show <$> regionStartLine region + , ("--end-line=" <>) . show <$> regionEndLine region + ] + ){cwd = Just $ takeDirectory fp'} + contents + case exitCode of + ExitSuccess -> do + logWith recorder Debug $ StdErr err + pure $ InL $ makeDiffTextEdit contents out + ExitFailure n -> do + logWith recorder Info $ StdErr err + throwError $ PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n) + +data LogEvent + = NoVersion Text + | ConfigPath FilePath + | NoConfigPath [FilePath] + | StdErr Text + | LogCompiledInVersion String + | LogExternalVersion [Int] + deriving (Show) + +instance Pretty LogEvent where + pretty = \case + NoVersion t -> "Couldn't get Fourmolu version:" <> line <> indent 2 (pretty t) + ConfigPath p -> "Loaded Fourmolu config from: " <> pretty (show p) + NoConfigPath ps -> "No " <> pretty configFileName <> " found in any of:" + <> line <> indent 2 (vsep (map (pretty . show) ps)) + StdErr t -> "Fourmolu stderr:" <> line <> indent 2 (pretty t) + LogCompiledInVersion v -> "Using compiled in fourmolu-" <> pretty v + LogExternalVersion v -> + "Using external fourmolu" + <> if null v then "" else "-" + <> pretty (intercalate "." $ map show v) + +convertDynFlags :: DynFlags -> [String] +convertDynFlags df = + let pp = ["-pgmF=" <> p | not (null p)] + p = sPgm_F $ Compat.settings df + pm = map (("-fplugin=" <>) . moduleNameString) $ pluginModNames df + ex = map showExtension $ S.toList $ extensionFlags df + showExtension = \case + Cpp -> "-XCPP" + x -> "-X" ++ show x + in pp <> pm <> ex + +newtype CLIVersionInfo = CLIVersionInfo + { noCabal :: Bool + } + +mwhen :: Monoid a => Bool -> a -> a +mwhen b x = if b then x else mempty + +#if !MIN_VERSION_fourmolu(0,14,0) +resolvePrinterOpts :: [PrinterOptsPartial] -> PrinterOptsTotal +resolvePrinterOpts = foldr fillMissingPrinterOpts defaultPrinterOpts +#endif diff --git a/plugins/hls-fourmolu-plugin/test/Main.hs b/plugins/hls-fourmolu-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/Main.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Functor +import Ide.Plugin.Config +import qualified Ide.Plugin.Fourmolu as Fourmolu +import Language.LSP.Protocol.Types +import Language.LSP.Test +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +fourmoluPlugin :: PluginTestDescriptor Fourmolu.LogEvent +fourmoluPlugin = mkPluginTestDescriptor Fourmolu.descriptor "fourmolu" + +tests :: TestTree +tests = + testGroup "fourmolu" $ + [False, True] <&> \cli -> + testGroup + (if cli then "cli" else "lib") + [ goldenWithFourmolu cli "formats correctly" "Fourmolu" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) + , goldenWithFourmolu cli "formats imports correctly" "Fourmolu2" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) + , goldenWithFourmolu cli "uses correct operator fixities" "Fourmolu3" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) + ] + +goldenWithFourmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithFourmolu cli title path desc = goldenWithHaskellDocFormatter def fourmoluPlugin "fourmolu" conf title testDataDir path desc "hs" + where + conf = def{plcConfig = KM.fromList ["external" .= cli]} + +testDataDir :: FilePath +testDataDir = "plugins" "hls-fourmolu-plugin" "test" "testdata" diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.formatted.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.formatted.hs @@ -0,0 +1,16 @@ +module Fourmolu where + +import Data.List + +import Data.Int +import Prelude + +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz {a :: Int, b :: String} diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu.hs @@ -0,0 +1,15 @@ +module Fourmolu where +import Data.List + +import Prelude +import Data.Int +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz { a :: Int, b :: String } + diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.formatted.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.formatted.hs @@ -0,0 +1,5 @@ +import Data.Bool +import Data.Char +import Data.Data +import Data.Either +import Data.Int diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu2.hs @@ -0,0 +1,5 @@ +import Data.Char +import Data.Either +import Data.Int +import Data.Data +import Data.Bool diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.formatted.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.formatted.hs @@ -0,0 +1,7 @@ +b :: Bool +b = + id $ + id $ + case True && True of + True -> True + False -> False diff --git a/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.hs b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/Fourmolu3.hs @@ -0,0 +1,6 @@ +b :: Bool +b = + id $ id $ + case True && True of + True -> True + False -> False diff --git a/plugins/hls-fourmolu-plugin/test/testdata/hie.yaml b/plugins/hls-fourmolu-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-fourmolu-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.GADT (descriptor) where + +import Control.Lens ((^.)) + +import Control.Monad.Error.Class (MonadError (throwError), + liftEither) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT, withExceptT) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Either.Extra (maybeToEither) +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat + +import Data.Maybe (mapMaybe) +import Development.IDE.Core.PluginUtils +import Development.IDE.Spans.Pragmas (getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Plugin.Error +import Ide.Plugin.GHC +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (sendRequest) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId "Provides a code action to convert datatypes to GADT syntax") + { Ide.Types.pluginHandlers = + mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler + , pluginCommands = + [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)] + } + +-- | Parameter used in the command +data ToGADTParams = ToGADTParams + { uri :: Uri + , range :: Range + } deriving (Generic, ToJSON, FromJSON) + +toGADTSyntaxCommandId :: CommandId +toGADTSyntaxCommandId = "GADT.toGADT" + +-- | A command replaces H98 data decl with GADT decl in place +toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams +toGADTCommand pId@(PluginId pId') state _ ToGADTParams{..} = withExceptT handleGhcidePluginError $ do + nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE uri + (decls, exts) <- getInRangeH98DeclsAndExts state range nfp + (L ann decl) <- case decls of + [d] -> pure d + _ -> throwError $ UnexpectedNumberOfDeclarations (Prelude.length decls) + deps <- withExceptT GhcidePluginErrors + $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state + $ useE GhcSessionDeps nfp + (hsc_dflags . hscEnv -> df) <- pure deps + txt <- withExceptT (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl + range <- liftEither + $ maybeToEither FailedToFindDataDeclRange + $ srcSpanToRange $ locA ann + pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp + let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] + + _ <- lift $ sendRequest + SMethod_WorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) + (\_ -> pure ()) + + pure $ InR Null + where + workSpaceEdit nfp edits = WorkspaceEdit + (pure $ Map.fromList + [(filePathToUri $ fromNormalizedFilePath nfp, + edits)]) + Nothing Nothing + +codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT handleGhcidePluginError $ do + nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE (doc ^. L.uri) + (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp + let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls + pure $ InL actions + where + mkAction :: T.Text -> Command |? CodeAction + mkAction name = InR CodeAction{..} + where + _title = "Convert \"" <> name <> "\" to GADT syntax" + _kind = Just CodeActionKind_RefactorRewrite + _diagnostics = Nothing + _isPreferred = Nothing + _disabled = Nothing + _edit = Nothing + _command = Just + $ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam]) + _data_ = Nothing + + mkParam = ToGADTParams (doc ^. L.uri) range + +-- | Get all H98 decls in the given range, and enabled extensions +getInRangeH98DeclsAndExts :: (MonadIO m) => + IdeState + -> Range + -> NormalizedFilePath + -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) +getInRangeH98DeclsAndExts state range nfp = do + pm <- withExceptT GhcidePluginErrors + $ runActionE "GADT.GetParsedModuleWithComments" state + $ useE GetParsedModuleWithComments nfp + let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm + decls = filter isH98DataDecl + $ mapMaybe getDataDecl + $ filter (inRange range) hsDecls + exts = getExtensions pm + pure (decls, exts) + +data GadtPluginError + = UnexpectedNumberOfDeclarations Int + | FailedToFindDataDeclRange + | PrettyGadtError T.Text + | GhcidePluginErrors PluginError + +handleGhcidePluginError :: + GadtPluginError -> + PluginError +handleGhcidePluginError = \case + UnexpectedNumberOfDeclarations nums -> do + PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums) + FailedToFindDataDeclRange -> + PluginInternalError "Unable to get data decl range" + PrettyGadtError errMsg -> + PluginInternalError errMsg + GhcidePluginErrors errors -> + errors diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +module Ide.Plugin.GHC where + +import Data.Functor ((<&>)) +import Data.List.Extra (stripInfix) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint +import GHC.Parser.Annotation (AddEpAnn (..), + Anchor (Anchor), + AnchorOperation (MovedAnchor), + DeltaPos (..), + EpAnn (..), + EpAnnComments (EpaComments), + EpaLocation (EpaDelta), + SrcSpanAnn' (SrcSpanAnn), + spanAsAnchor) +import Ide.PluginUtils (subRange) +import Language.Haskell.GHC.ExactPrint (showAst) +import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) + +#if MIN_VERSION_ghc(9,5,0) +import qualified Data.List.NonEmpty as NE +import GHC.Parser.Annotation (TokenLocation (..)) +#endif + +type GP = GhcPass Parsed + +-- | Check if a given range is in the range of located item +inRange :: HasSrcSpan a => Range -> a -> Bool +inRange range s = maybe False (subRange range) (srcSpanToRange (getLoc s)) + +-- | Get data decl and its location +getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP) +getDataDecl (L l (TyClD _ d@DataDecl{})) = Just (L l d) +getDataDecl _ = Nothing + +isConDeclH98 :: ConDecl GP -> Bool +isConDeclH98 ConDeclH98{} = True +isConDeclH98 _ = False + +isH98DataDecl :: LTyClDecl GP -> Bool +isH98DataDecl (L _ decl@DataDecl{}) = + any (isConDeclH98 . (\(L _ r) -> r)) (dd_cons $ tcdDataDefn decl) +isH98DataDecl _ = False + +-- | Convert H98 data type definition to GADT's +h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP +h98ToGADTDecl = \case + DataDecl{..} -> DataDecl + { tcdDataDefn = updateDefn tcdLName tcdTyVars tcdDataDefn + , .. + } + x -> x + where + updateDefn dataName tyVars = \case + HsDataDefn{..} -> HsDataDefn + { dd_cons = + mapX (h98ToGADTConDecl dataName tyVars (wrapCtxt dd_ctxt)) <$> dd_cons + , dd_ctxt = emptyCtxt -- Context can't appear at the data name in GADT + , .. + } + x -> x + +-- | Convert H98 data constructor to GADT data constructor +h98ToGADTConDecl :: + LIdP GP -- ^Type constructor name, + -- used for constructing final result type in GADT + -> LHsQTyVars GP + -- ^Type variable names + -- used for constructing final result type in GADT + -> Maybe (LHsContext GP) + -- ^Data type context + -> ConDecl GP + -> ConDecl GP +h98ToGADTConDecl dataName tyVars ctxt = \case + ConDeclH98{..} -> + ConDeclGADT + con_ext +#if MIN_VERSION_ghc(9,5,0) + (NE.singleton con_name) +#else + [con_name] +#endif + +#if MIN_VERSION_ghc(9,5,0) + (L NoTokenLoc HsNormalTok) +#endif + -- Ignore all existential type variable since GADT not needed + implicitTyVars + (mergeContext ctxt con_mb_cxt) + (renderDetails con_args) + renderResultTy + con_doc + x -> x + where + -- Parameters in the data constructor + renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP + renderDetails (PrefixCon _ args) = PrefixConGADT args + renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2] +#if MIN_VERSION_ghc(9,3,0) + renderDetails (RecCon recs) = RecConGADT recs noHsUniTok +#else + renderDetails (RecCon recs) = RecConGADT recs +#endif + + + -- | Construct GADT result type + renderResultTy :: LHsType GP + renderResultTy = case tyVars of + -- Without type variable + HsQTvs _ [] -> wrappedDataName + -- With type variable + HsQTvs _ vars -> foldl go wrappedDataName vars + _ -> wrappedDataName + where + wrappedDataName = wrap (HsTyVar noUsed NotPromoted dataName) + + -- Bundle data name with type vars by `HsAppTy` + go acc (L _(UserTyVar' var)) = + wrap + (HsAppTy noExtField acc + (wrap (HsTyVar noUsed NotPromoted var))) + go acc _ = acc + + -- Merge data type context and constructor type context + mergeContext :: Maybe (LHsContext GP) -> Maybe (LHsContext GP) -> Maybe (LHsContext GP) + mergeContext ctxt1 ctxt2 = + (wrap . map wrap) . map unParTy + <$> (getContextType ctxt1 <> getContextType ctxt2) + where + getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP] + getContextType ctxt = map unWrap . unWrap <$> ctxt + + -- Unparen the outmost, it only occurs at the outmost + -- for a valid type. + -- + -- Note for context paren rule: + -- + -- If only one element, it __can__ have a paren type. + -- If not, there can't have a parent type. + unParTy :: HsType GP -> HsType GP + unParTy (HsParTy _ ty) = unWrap ty + unParTy x = x +{- | +We use `printOutputable` to print H98 data decl as GADT syntax, +this print is not perfect, it will: + +1. Make data name and the `where` key word in different lines. +2. Make the whole data decl prints in one line if there is only one data constructor. +3. The ident size of every data constructor depends on its origin + format, and may have different ident size between constructors. + +Hence, we first use `printOutputable` to get an initial GADT syntax, +then use `ghc-exactprint` to parse the initial result, and finally +adjust the details that mentioned above. + +The adjustment includes: + +1. Make the `where` key word at the same line of data name. +2. Remove the extra blank line caused by adjustment of `where`. +3. Make every data constructor start with a new line and 2 spaces +-} +prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String +prettyGADTDecl df decl = + let old = printOutputable decl + hsDecl = parseDecl df "unused" (T.unpack old) + tycld = adjustTyClD hsDecl + in removeExtraEmptyLine . exactPrint <$> tycld + where + adjustTyClD = \case + Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld + Right x -> Left $ "Expect TyClD but got " <> showAst x +#if MIN_VERSION_ghc(9,3,0) + Left err -> Left $ printWithoutUniques err +#else + Left err -> Left $ show err +#endif + + adjustDataDecl DataDecl{..} = DataDecl + { tcdDExt = adjustWhere tcdDExt + , tcdDataDefn = tcdDataDefn + { dd_cons = + fmap adjustCon (dd_cons tcdDataDefn) + } + , .. + } + adjustDataDecl x = x + + -- Make every data constructor start with a new line and 2 spaces + adjustCon :: LConDecl GP -> LConDecl GP + adjustCon (L (SrcSpanAnn _ loc) r) = + L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r + where + go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2)) + + -- Adjust where annotation to the same line of the type constructor + adjustWhere tcdDExt = tcdDExt <&> map + (\(AddEpAnn ann l) -> + if ann == AnnWhere + then AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) + else AddEpAnn ann l + ) + + -- Remove the first extra line if exist + removeExtraEmptyLine s = case stripInfix "\n\n" s of + Just (x, xs) -> x <> "\n" <> xs + Nothing -> s + +wrap :: forall a. WrapXRec GP a => a -> XRec GP a +wrap = wrapXRec @GP +wrapCtxt = id +emptyCtxt = Nothing +unWrap = unXRec @GP +mapX = mapXRec @GP +noUsed = EpAnnNotUsed + +pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass +pattern UserTyVar' s <- UserTyVar _ _ s + +implicitTyVars = wrapXRec @GP mkHsOuterImplicit diff --git a/plugins/hls-gadt-plugin/test/Main.hs b/plugins/hls-gadt-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/Main.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import Control.Monad (void) +import Data.Either (rights) +import qualified Data.Text as T +import qualified Ide.Plugin.GADT as GADT +import System.FilePath (()) +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +gadtPlugin :: PluginTestDescriptor () +gadtPlugin = mkPluginTestDescriptor' GADT.descriptor "GADT" + +tests :: TestTree +tests = testGroup "GADT" + [ runTest "range" "SimpleData" 2 0 2 1 + , runTest "SimpleData" "SimpleData" 2 0 2 10 + , runTest "SimpleNewtype" "SimpleNewtype" 2 0 2 17 + , runTest "Data" "Data" 2 0 2 36 + , runTest "Newtype" "Newtype" 2 0 2 21 + , runTest "Deriving" "Deriving" 2 0 2 56 + , runTest "Infix" "Infix" 2 0 2 35 + , runTest "Record" "Record" 2 0 5 1 + , runTest "TypeVariable" "TypeVariable" 2 0 2 32 + , runTest "DataContext" "DataContext" 2 0 2 31 + , runTest "DataContextParen" "DataContextParen" 2 0 3 6 + , runTest "Forall" "Forall" 2 0 2 44 + , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38 + , runTest "Context" "Context" 2 0 4 41 + , runTest "Pragma" "Pragma" 2 0 3 29 + , runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14 + , gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False + ] + +gadtPragmaTest :: TestName -> Bool -> TestTree +gadtPragmaTest title hasGADT = testCase title + $ withCanonicalTempDir + $ \dir -> runSessionWithServer def gadtPlugin dir $ do + doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"]) + _ <- waitForProgressDone + (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1)) + executeCodeAction act + let expected = T.unlines $ + ["{-# LANGUAGE GADTs #-}" | hasGADT] ++ + ["module A where", "data Foo where", " Bar :: Foo"] + contents <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ contents @?= expected + +runTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +runTest title fp x1 y1 x2 y2 = + goldenWithHaskellDoc def gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do + _ <- waitForProgressDone + (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position x1 y1) (Position x2 y2)) + executeCodeAction act + void $ skipManyTill anyMessage (getDocumentEdit doc) + +findGADTAction :: [a |? CodeAction] -> [CodeAction] +findGADTAction = filter isGADTCodeAction . rights . map toEither + +isGADTCodeAction :: CodeAction -> Bool +isGADTCodeAction CodeAction{..} = case _kind of + Nothing -> False + Just kind -> case kind of + CodeActionKind_RefactorRewrite -> True + _ -> False + +testDataDir :: FilePath +testDataDir = "plugins" "hls-gadt-plugin" "test" "testdata" diff --git a/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs @@ -0,0 +1,4 @@ +module ConstructorContext where + +data Foo where + Bar :: Show a => a -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs @@ -0,0 +1,3 @@ +module ConstructorContext where + +data Foo = forall a. (Show a) => Bar a diff --git a/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs @@ -0,0 +1,5 @@ +module Context where + +data Foo a where + Bar :: (Eq a, Show b, Show a) => a -> b -> Foo a + Baz :: (Eq a, Show c) => c -> c -> Foo a diff --git a/plugins/hls-gadt-plugin/test/testdata/Context.hs b/plugins/hls-gadt-plugin/test/testdata/Context.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Context.hs @@ -0,0 +1,5 @@ +module Context where + +data (Eq a) => Foo a = + forall b c. (Show b, Show a) => + Bar a b | forall c. (Show c) => Baz c c diff --git a/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs @@ -0,0 +1,5 @@ +module Data where + +data Foo where + Bar :: Int -> Foo + Baz :: Char -> String -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Data.hs b/plugins/hls-gadt-plugin/test/testdata/Data.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Data.hs @@ -0,0 +1,3 @@ +module Data where + +data Foo = Bar Int | Baz Char String diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs b/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs @@ -0,0 +1,5 @@ +module DataContext where + +data T a b where + F :: Ord a => a -> T a b + G :: Ord a => b -> T a b diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContext.hs b/plugins/hls-gadt-plugin/test/testdata/DataContext.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContext.hs @@ -0,0 +1,3 @@ +module DataContext where + +data Ord a => T a b = F a | G b diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs @@ -0,0 +1,4 @@ +module DataContextParen where + +data F a where + G :: Eq a => a -> F a diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs @@ -0,0 +1,4 @@ +module DataContextParen where + +data (Eq a) => F a + = G a diff --git a/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs @@ -0,0 +1,6 @@ +module Deriving where + +data Foo where + Bar :: Int -> Foo + Baz :: Char -> String -> Foo + deriving (Show, Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/Deriving.hs b/plugins/hls-gadt-plugin/test/testdata/Deriving.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Deriving.hs @@ -0,0 +1,3 @@ +module Deriving where + +data Foo = Bar Int | Baz Char String deriving (Show, Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs @@ -0,0 +1,4 @@ +module Forall where + +data Foo where + Bar :: Show a => a -> b -> a -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Forall.hs b/plugins/hls-gadt-plugin/test/testdata/Forall.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Forall.hs @@ -0,0 +1,3 @@ +module Forall where + +data Foo = forall a b. (Show a) => Bar a b a diff --git a/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs @@ -0,0 +1,5 @@ +module Infix where + +data Foo where + (:->) :: Int -> Char -> Foo + deriving () diff --git a/plugins/hls-gadt-plugin/test/testdata/Infix.hs b/plugins/hls-gadt-plugin/test/testdata/Infix.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Infix.hs @@ -0,0 +1,3 @@ +module Infix where + +data Foo = Int :-> Char deriving () diff --git a/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs @@ -0,0 +1,4 @@ +module Newtype where + +newtype Foo where + Bar :: Int -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Newtype.hs b/plugins/hls-gadt-plugin/test/testdata/Newtype.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Newtype.hs @@ -0,0 +1,3 @@ +module Newtype where + +newtype Foo = Bar Int diff --git a/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs @@ -0,0 +1,5 @@ +module Pragma where + +data F where + G :: {-# UNPACK #-}Int -> F + H :: {-# NOUNPACK #-}Char -> F diff --git a/plugins/hls-gadt-plugin/test/testdata/Pragma.hs b/plugins/hls-gadt-plugin/test/testdata/Pragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Pragma.hs @@ -0,0 +1,4 @@ +module Pragma where + +data F = G{-# UNPACK #-}Int + | H {-# NOUNPACK #-} Char diff --git a/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs @@ -0,0 +1,4 @@ +module Record where + +data Foo where + Foo :: {bar :: Char, baz :: Int} -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Record.hs b/plugins/hls-gadt-plugin/test/testdata/Record.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Record.hs @@ -0,0 +1,6 @@ +module Record where + +data Foo = Foo { + bar :: Char, + baz :: Int +} diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs @@ -0,0 +1,4 @@ +module SimpleData where + +data A where + B :: A diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs @@ -0,0 +1,3 @@ +module SimpleData where + +data A = B diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs @@ -0,0 +1,4 @@ +module SimpleNewtype where + +newtype A where + B :: Int -> A diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs @@ -0,0 +1,3 @@ +module SimpleNewtype where + +newtype A = B Int diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs @@ -0,0 +1,5 @@ +module SingleDeriving where + +data Foo a b where + Bar :: b -> a -> Foo a b + deriving Eq diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs @@ -0,0 +1,4 @@ +module SingleDeriving where + +data Foo a b = Bar b a + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs @@ -0,0 +1,5 @@ +module SingleDerivingGHC92 where + +data Foo a b where + Bar :: b -> a -> Foo a b + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs @@ -0,0 +1,4 @@ +module SingleDerivingGHC92 where + +data Foo a b = Bar b a + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs @@ -0,0 +1,5 @@ +module TypeVariable where + +data Foo a f where + Foo :: a -> Foo a f + Bar :: (f a) -> Foo a f diff --git a/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs @@ -0,0 +1,3 @@ +module TypeVariable where + +data Foo a f = Foo a | Bar (f a) diff --git a/plugins/hls-gadt-plugin/test/testdata/hie.yaml b/plugins/hls-gadt-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: ["-XHaskell2010", "-XExistentialQuantification", "-XGADTs"] diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -0,0 +1,687 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- On 9.4 we get a new redundant constraint warning, but deleting the +-- constraint breaks the build on earlier versions. Rather than apply +-- lots of CPP, we just disable the warning until later. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +#ifdef HLINT_ON_GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +module Ide.Plugin.Hlint + ( + descriptor + , Log(..) + ) where +import Control.Arrow ((&&&)) +import Control.Concurrent.STM +import Control.DeepSeq +import Control.Exception +import Control.Lens ((?~), (^.)) +import Control.Monad +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) +import Data.Aeson.Types (FromJSON (..), + ToJSON (..), + Value (..)) +import qualified Data.ByteString as BS +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Typeable +import Development.IDE hiding + (Error, + getExtensions) +import Development.IDE.Core.Compile (sourceParser) +import Development.IDE.Core.Rules (defineNoFile, + getParsedModuleWithComments) +import Development.IDE.Core.Shake (getDiagnostics) +import qualified Refact.Apply as Refact +import qualified Refact.Types as Refact + +#ifdef HLINT_ON_GHC_LIB +import Development.IDE.GHC.Compat (DynFlags, + WarningFlag (Opt_WarnUnrecognisedPragmas), + extensionFlags, + ms_hspp_opts, + topDir, + wopt) +import qualified Development.IDE.GHC.Compat.Util as EnumSet + +#if MIN_GHC_API_VERSION(9,4,0) +import qualified "ghc-lib-parser" GHC.Data.Strict as Strict +#endif +#if MIN_GHC_API_VERSION(9,0,0) +import "ghc-lib-parser" GHC.Types.SrcLoc hiding + (RealSrcSpan) +import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC +#else +import "ghc-lib-parser" SrcLoc hiding + (RealSrcSpan) +import qualified "ghc-lib-parser" SrcLoc as GHC +#endif +import "ghc-lib-parser" GHC.LanguageExtensions (Extension) +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +import System.FilePath (takeFileName) +import System.IO (IOMode (WriteMode), + hClose, + hPutStr, + hSetEncoding, + hSetNewlineMode, + noNewlineTranslation, + utf8, + withFile) +import System.IO.Temp +#else +import Development.IDE.GHC.Compat hiding + (setEnv, + (<+>)) +import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) +#if MIN_GHC_API_VERSION(9,2,0) +import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions) +#else +import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) +#endif +import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) +import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) +import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) +import qualified Refact.Fixity as Refact +#endif +import Ide.Plugin.Config hiding + (Config) +import Ide.Plugin.Error +import Ide.Plugin.Properties +import Ide.Plugin.Resolve +import Ide.PluginUtils +import Ide.Types hiding + (Config) +import Language.Haskell.HLint as Hlint +import qualified Language.LSP.Protocol.Lens as LSP +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (Null) +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Server (getVersionedTextDoc) + +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), + NextPragmaInfo (NextPragmaInfo), + getNextPragmaInfo, + lineSplitDeleteTextEdit, + lineSplitInsertTextEdit, + lineSplitTextEdits, + nextPragmaLine) +import GHC.Generics (Generic) +#if !MIN_VERSION_apply_refact(0,12,0) +import System.Environment (setEnv, + unsetEnv) +#endif +import Development.IDE.Core.PluginUtils as PluginUtils +import Text.Regex.TDFA.Text () +-- --------------------------------------------------------------------- + +data Log + = LogShake Shake.Log + | LogApplying NormalizedFilePath (Either String WorkspaceEdit) + | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] + | LogGetIdeas NormalizedFilePath + | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them + | forall a. (Pretty a) => LogResolve a + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res + LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas + LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts + LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp + LogResolve msg -> pretty msg + +#ifdef HLINT_ON_GHC_LIB +-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib +#if !MIN_GHC_API_VERSION(9,0,0) +type BufSpan = () +#endif +pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan +#if MIN_GHC_API_VERSION(9,4,0) +pattern RealSrcSpan x y <- GHC.RealSrcSpan x (fromStrictMaybe -> y) +#elif MIN_GHC_API_VERSION(9,0,0) +pattern RealSrcSpan x y = GHC.RealSrcSpan x y +#else +pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y)) +#endif +{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} +#endif + +#if MIN_GHC_API_VERSION(9,4,0) +fromStrictMaybe :: Strict.Maybe a -> Maybe a +fromStrictMaybe (Strict.Just a ) = Just a +fromStrictMaybe Strict.Nothing = Nothing +#endif + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder) + desc = "Provides HLint diagnostics and code actions. Built with hlint-" <> VERSION_hlint + in (defaultPluginDescriptor plId desc) + { pluginRules = rules recorder plId + , pluginCommands = pluginCommands + , pluginHandlers = pluginHandlers + , pluginConfigDescriptor = defaultConfigDescriptor + { configHasDiagnostics = True + , configCustomConfig = mkCustomConfig properties + } + } + +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty +data GetHlintDiagnostics = GetHlintDiagnostics + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintDiagnostics +instance NFData GetHlintDiagnostics + +type instance RuleResult GetHlintDiagnostics = () + +-- | Hlint rules to generate file diagnostics based on hlint hints +-- | This rule is recomputed when: +-- | - A file has been edited via +-- | - `getIdeas` -> `getParsedModule` in any case +-- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc +-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` +-- | - The hlint specific settings have changed, via `getHlintSettingsRule` +rules :: Recorder (WithPriority Log) -> PluginId -> Rules () +rules recorder plugin = do + define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do + config <- getPluginConfigAction plugin + let hlintOn = plcGlobalOn config && plcDiagnosticsOn config + ideas <- if hlintOn then getIdeas recorder file else return (Right []) + return (diagnostics file ideas, Just ()) + + defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do + (Config flags) <- getHlintConfig plugin + liftIO $ argsSettings flags + + action $ do + files <- getFilesOfInterestUntracked + void $ uses GetHlintDiagnostics $ Map.keys files + + where + + diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] + diagnostics file (Right ideas) = + (file, ShowDiag,) <$> catMaybes [ideaToDiagnostic i | i <- ideas] + diagnostics file (Left parseErr) = + [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + + + ideaToDiagnostic :: Idea -> Maybe Diagnostic + ideaToDiagnostic idea = do + diagnosticSeverity <- ideaSeverityToDiagnosticSeverity (ideaSeverity idea) + pure $ + LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan idea + , _severity = Just diagnosticSeverity + -- we are encoding the fact that idea has refactorings in diagnostic code + , _code = Just (InR $ T.pack $ codePre ++ ideaHint idea) + , _source = Just "hlint" + , _message = idea2Message idea + , _relatedInformation = Nothing + , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } + + where + codePre = if null $ ideaRefactoring idea then "" else "refact:" + + -- We only propogate error severity of hlint and downgrade other severities to Info. + -- Currently, there are just 2 error level serverities present in hlint by default: https://github.com/ndmitchell/hlint/issues/1549#issuecomment-1892701824. + -- And according to ndmitchell: The default error level severities of the two hints are justified and it's fairly uncommon to happen. + -- GH Issue about discussion on this: https://github.com/ndmitchell/hlint/issues/1549 + ideaSeverityToDiagnosticSeverity :: Hlint.Severity -> Maybe LSP.DiagnosticSeverity + ideaSeverityToDiagnosticSeverity Hlint.Ignore = Nothing + ideaSeverityToDiagnosticSeverity Hlint.Suggestion = Just LSP.DiagnosticSeverity_Information + ideaSeverityToDiagnosticSeverity Hlint.Warning = Just LSP.DiagnosticSeverity_Information + ideaSeverityToDiagnosticSeverity Hlint.Error = Just LSP.DiagnosticSeverity_Error + + idea2Message :: Idea -> T.Text + idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", " " <> T.pack (ideaFrom idea)] + <> toIdea <> map (T.pack . show) (ideaNote idea) + where + toIdea :: [T.Text] + toIdea = case ideaTo idea of + Nothing -> [] + Just i -> [T.pack "Why not:", T.pack $ " " ++ i] + + + parseErrorToDiagnostic :: ParseError -> Diagnostic + parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + LSP.Diagnostic { + _range = srcSpanToRange l + , _severity = Just LSP.DiagnosticSeverity_Information + , _code = Just (InR sourceParser) + , _source = Just "hlint" + , _message = T.unlines [T.pack msg,T.pack contents] + , _relatedInformation = Nothing + , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } + + -- This one is defined in Development.IDE.GHC.Error but here + -- the types could come from ghc-lib or ghc + srcSpanToRange :: SrcSpan -> LSP.Range + srcSpanToRange (RealSrcSpan span _) = Range { + _start = LSP.Position { + _line = fromIntegral $ srcSpanStartLine span - 1 + , _character = fromIntegral $ srcSpanStartCol span - 1} + , _end = LSP.Position { + _line = fromIntegral $ srcSpanEndLine span - 1 + , _character = fromIntegral $ srcSpanEndCol span - 1} + } + srcSpanToRange (UnhelpfulSpan _) = noRange + +getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas recorder nfp = do + logWith recorder Debug $ LogGetIdeas nfp + (flags, classify, hint) <- useNoFile_ GetHlintSettings + + let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] + applyHints' (Just (Left err)) = Left err + applyHints' Nothing = Right [] + + fmap applyHints' (moduleEx flags) + + where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) +#ifndef HLINT_ON_GHC_LIB + moduleEx _flags = do + mbpm <- getParsedModuleWithComments nfp + return $ createModule <$> mbpm + where + createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu)) + where anns = pm_annotations pm + modu = pm_parsed_source pm + + applyParseFlagsFixities :: ParsedSource -> ParsedSource + applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul + + parseFlagsToFixities :: ParseFlags -> [(String, Fixity)] + parseFlagsToFixities = map toFixity . Hlint.fixities + + toFixity :: FixityInfo -> (String, Fixity) + toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir) + where + f LeftAssociative = InfixL + f RightAssociative = InfixR + f NotAssociative = InfixN +#else + moduleEx flags = do + mbpm <- getParsedModuleWithComments nfp + -- If ghc was not able to parse the module, we disable hlint diagnostics + if isNothing mbpm + then return Nothing + else do + flags' <- setExtensions flags + (_, contents) <- getFileContents nfp + let fp = fromNormalizedFilePath nfp + let contents' = T.unpack <$> contents + Just <$> liftIO (parseModuleEx flags' fp contents') + + setExtensions flags = do + hlintExts <- getExtensions nfp + logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts) + return $ flags { enabledExtensions = hlintExts } + +-- Gets extensions from ModSummary dynflags for the file. +-- Previously this would union extensions from both hlint's parsedFlags +-- and the ModSummary dynflags. However using the parsedFlags extensions +-- can sometimes interfere with the hlint parsing of the file. +-- See https://github.com/haskell/haskell-language-server/issues/1279 +-- +-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need +-- these extensions to construct dynflags to parse the file again. Therefore +-- using hlint default extensions doesn't seem to be a problem when +-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again. +getExtensions :: NormalizedFilePath -> Action [Extension] +getExtensions nfp = do + dflags <- getFlags + let hscExts = EnumSet.toList (extensionFlags dflags) + let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts + return hscExts' + where getFlags :: Action DynFlags + getFlags = do + modsum <- use_ GetModSummary nfp + return $ ms_hspp_opts $ msrModSummary modsum +#endif + +-- --------------------------------------------------------------------- + +data GetHlintSettings = GetHlintSettings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintSettings +instance NFData GetHlintSettings +instance NFData Hint where rnf = rwhnf +instance NFData Classify where rnf = rwhnf +instance NFData ParseFlags where rnf = rwhnf +instance Show Hint where show = const "" +instance Show ParseFlags where show = const "" + +type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) + +-- --------------------------------------------------------------------- + +newtype Config = Config [String] + +properties :: Properties '[ 'PropertyKey "flags" ('TArray String)] +properties = emptyProperties + & defineArrayProperty #flags + "Flags used by hlint" [] + +-- | Get the plugin config +getHlintConfig :: PluginId -> Action Config +getHlintConfig pId = + Config + <$> usePropertyAction #flags pId properties + +-- --------------------------------------------------------------------- +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context) + | let TextDocumentIdentifier uri = documentId + , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) + = do + verTxtDocId <- lift $ getVersionedTextDoc documentId + liftIO $ fmap (InL . map LSP.InR) $ do + allDiagnostics <- atomically $ getDiagnostics ideState + + let numHintsInDoc = length + [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics + , validCommand diagnostic + , diagnosticNormalizedFilePath == docNormalizedFilePath + ] + let numHintsInContext = length + [diagnostic | diagnostic <- diags + , validCommand diagnostic + ] + let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId + if numHintsInDoc > 1 && numHintsInContext > 0 then do + pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId] + else + pure singleHintCodeActions + | otherwise + = pure $ InL [] + + where + applyAllAction verTxtDocId = + let args = Just $ toJSON (ApplyHint verTxtDocId Nothing) + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args + + -- |Some hints do not have an associated refactoring + validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) = + "refact:" `T.isPrefixOf` code + validCommand _ = + False + + diags = context ^. LSP.diagnostics + +resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve +resolveProvider recorder ideState _plId ca uri resolveValue = do + file <- getNormalizedFilePathE uri + case resolveValue of + (ApplyHint verTxtDocId oneHint) -> do + edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId + pure $ ca & LSP.edit ?~ edit + (IgnoreHint verTxtDocId hintTitle ) -> do + edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle + pure $ ca & LSP.edit ?~ edit + +-- | Convert a hlint diagnostic into an apply and an ignore code action +-- if applicable +diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] +diagnosticToCodeActions verTxtDocId diagnostic + | LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic + , let isHintApplicable = "refact:" `T.isPrefixOf` code + , let hint = T.replace "refact:" "" code + , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" + , let suppressHintArguments = IgnoreHint verTxtDocId hint + = catMaybes + -- Applying the hint is marked preferred because it addresses the underlying error. + -- Disabling the rule isn't, because less often used and configuration can be adapted. + [ if | isHintApplicable + , let applyHintTitle = "Apply hint \"" <> hint <> "\"" + applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) -> + Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True) + | otherwise -> Nothing + , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False) + ] + | otherwise = [] + +mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction +mkCodeAction title diagnostic data_ isPreferred = + LSP.CodeAction + { _title = title + , _kind = Just LSP.CodeActionKind_QuickFix + , _diagnostics = Just [diagnostic] + , _isPreferred = Just isPreferred + , _disabled = Nothing + , _edit = Nothing + , _command = Nothing + , _data_ = data_ + } + +mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] +mkSuppressHintTextEdits dynFlags fileContents hint = + let + NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents) + nextPragmaLinePosition = Position (fromIntegral nextPragmaLine) 0 + nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition + wnoUnrecognisedPragmasText = + if wopt Opt_WarnUnrecognisedPragmas dynFlags + then Just "{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n" + else Nothing + hlintIgnoreText = Just ("{-# HLINT ignore \"" <> hint <> "\" #-}\n") + -- we combine the texts into a single text because lsp-test currently + -- applies text edits backwards and I want the options pragma to + -- appear above the hlint pragma in the tests + combinedText = mconcat $ catMaybes [wnoUnrecognisedPragmasText, hlintIgnoreText] + combinedTextEdit = LSP.TextEdit nextPragmaRange combinedText + lineSplitTextEditList = maybe [] (\LineSplitTextEdits{..} -> [lineSplitInsertTextEdit, lineSplitDeleteTextEdit]) lineSplitTextEdits + in + combinedTextEdit : lineSplitTextEditList +-- --------------------------------------------------------------------- + +ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit) +ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do + (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp + (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp + case fileContents of + Just contents -> do + let dynFlags = ms_hspp_opts $ msrModSummary msr + textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle + workspaceEdit = + LSP.WorkspaceEdit + (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits)) + Nothing + Nothing + pure workspaceEdit + Nothing -> throwError $ PluginInternalError "Unable to get fileContents" + +-- --------------------------------------------------------------------- +data HlintResolveCommands = + ApplyHint + { verTxtDocId :: VersionedTextDocumentIdentifier + -- |If Nothing, apply all hints, otherise only apply + -- the given hint + , oneHint :: Maybe OneHint + } + | IgnoreHint + { verTxtDocId :: VersionedTextDocumentIdentifier + , ignoreHintTitle :: HintTitle + } deriving (Generic, ToJSON, FromJSON) + +type HintTitle = T.Text + +data OneHint = + OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Generic, Eq, Show, ToJSON, FromJSON) + +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit) +applyHint recorder ide nfp mhint verTxtDocId = + runExceptT $ do + let runAction' :: Action a -> IO a + runAction' = runAction "applyHint" ide + let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] + ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp + let ideas' = maybe ideas (`filterIdeas` ideas) mhint + let commands = map ideaRefactoring ideas' + logWith recorder Debug $ LogGeneratedIdeas nfp commands + let fp = fromNormalizedFilePath nfp + (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp + oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent + modsum <- liftIO $ runAction' $ use_ GetModSummary nfp + let dflags = ms_hspp_opts $ msrModSummary modsum + + -- set Nothing as "position" for "applyRefactorings" because + -- applyRefactorings expects the provided position to be _within_ the scope + -- of each refactoring it will apply. + -- But "Idea"s returned by HLint point to starting position of the expressions + -- that contain refactorings, so they are often outside the refactorings' boundaries. + let position = Nothing +#ifdef HLINT_ON_GHC_LIB + let writeFileUTF8NoNewLineTranslation file txt = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hSetNewlineMode h noNewlineTranslation + hPutStr h (T.unpack txt) + res <- + liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do + hClose h + writeFileUTF8NoNewLineTranslation temp oldContent + exts <- runAction' $ getExtensions nfp + -- We have to reparse extensions to remove the invalid ones + let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts + let refactExts = map show $ enabled ++ disabled + (Right <$> applyRefactorings (topDir dflags) position commands temp refactExts) + `catches` errorHandlers +#else + mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp + res <- + case mbParsedModule of + Nothing -> throwError "Apply hint: error parsing the module" + Just pm -> do + let anns = pm_annotations pm + let modu = pm_parsed_source pm + -- apply-refact uses RigidLayout + let rigidLayout = deltaOptions RigidLayout + (anns', modu') <- + ExceptT $ mapM (uncurry Refact.applyFixities) + $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout + liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu') + `catches` errorHandlers +#endif + case res of + Right appliedFile -> do + let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions + ExceptT $ return (Right wsEdit) + Left err -> + throwError $ PluginInternalError $ T.pack err + where + -- | If we are only interested in applying a particular hint then + -- let's filter out all the irrelevant ideas + filterIdeas :: OneHint -> [Idea] -> [Idea] + filterIdeas (OneHint (Position l c) title) ideas = + let title' = T.unpack title + ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan + in filter (\i -> ideaHint i == title' && ideaPos i == (fromIntegral $ l+1, fromIntegral $ c+1)) ideas + + toRealSrcSpan (RealSrcSpan real _) = real + toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x + + showParseError :: Hlint.ParseError -> String + showParseError (Hlint.ParseError location message content) = + unlines [show location, message, content] + +-- | Map over both failure and success. +bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b +bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where + h (Left e) = Left (f e) + h (Right a) = Right (g a) +{-# INLINE bimapExceptT #-} + +-- --------------------------------------------------------------------------- +-- Apply-refact compatability, documentation copied from upstream apply-refact +-- --------------------------------------------------------------------------- + +-- | Apply a set of refactorings as supplied by HLint +-- +-- This compatibility function abstracts over https://github.com/mpickering/apply-refact/issues/133 +-- for backwards compatability. +applyRefactorings :: + -- | FilePath to [GHC's libdir](https://downloads.haskell.org/ghc/latest/docs/users_guide/using.html#ghc-flag---print-libdir). + -- + -- It is possible to use @libdir@ from [ghc-paths package](https://hackage.haskell.org/package/ghc-paths), but note + -- this will make it difficult to provide a binary distribution of your program. + FilePath -> + -- | Apply hints relevant to a specific position + Maybe (Int, Int) -> + -- | 'Refactoring's to apply. Each inner list corresponds to an HLint + -- . + -- An @Idea@ may have more than one 'Refactoring'. + -- + -- The @Idea@s are sorted in ascending order of starting location, and are applied + -- in that order. If two @Idea@s start at the same location, the one with the larger + -- source span comes first. An @Idea@ is filtered out (ignored) if there is an @Idea@ + -- prior to it which has an overlapping source span and is not filtered out. + [[Refact.Refactoring Refact.SrcSpan]] -> + -- | Target file + FilePath -> + -- | GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left + -- to right. An extension (e.g., @StarIsType@) may be overridden later (e.g., by @NoStarIsType@). + -- + -- These are in addition to the @LANGUAGE@ pragmas in the target file. When they conflict + -- with the @LANGUAGE@ pragmas, pragmas win. + [String] -> + IO String +applyRefactorings = +#if MIN_VERSION_apply_refact(0,12,0) + Refact.applyRefactorings +#else + \libdir pos refacts fp exts -> withRuntimeLibdir libdir (Refact.applyRefactorings pos refacts fp exts) + + where + -- Setting a environment variable with the libdir used by ghc-exactprint. + -- It is a workaround for an error caused by the use of a hardcoded at compile time libdir + -- in ghc-exactprint that makes dependent executables non portables. + -- See https://github.com/alanz/ghc-exactprint/issues/96. + -- WARNING: this code is not thread safe, so if you try to apply several async refactorings + -- it could fail. That case is not very likely so we assume the risk. + withRuntimeLibdir :: FilePath -> IO a -> IO a + withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key) + where key = "GHC_EXACTPRINT_GHC_LIBDIR" +#endif diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main + ( main + ) where + +import Control.Lens ((^.)) +import Control.Monad (when) +import Data.Aeson (Value (..), object, (.=)) +import Data.Functor (void) +import Data.List (find) +import qualified Data.Map as Map +import Data.Maybe (fromJust, isJust) +import Data.Row ((.+), (.==)) +import qualified Data.Text as T +import Ide.Plugin.Config (Config (..)) +import qualified Ide.Plugin.Config as Plugin +import qualified Ide.Plugin.Hlint as HLint +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath (()) +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +hlintPlugin :: PluginTestDescriptor HLint.Log +hlintPlugin = mkPluginTestDescriptor HLint.descriptor "hlint" + +tests :: TestTree +tests = testGroup "hlint" [ + suggestionsTests + , configTests + , ignoreHintTests + , applyHintTests + , resolveTests + ] + +getIgnoreHintText :: T.Text -> T.Text +getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" + +getApplyHintText :: T.Text -> T.Text +getApplyHintText name = "Apply hint \"" <> name <> "\"" + +resolveTests :: TestTree +resolveTests = testGroup "hlint resolve tests" + [ + ignoreHintGoldenResolveTest + "Resolve version of: Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off" + "UnrecognizedPragmasOff" + (Point 3 8) + "Eta reduce" + , applyHintGoldenResolveTest + "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + + +ignoreHintTests :: TestTree +ignoreHintTests = testGroup "hlint ignore hint tests" + [ + ignoreHintGoldenTest + "Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off" + "UnrecognizedPragmasOff" + (Point 3 8) + "Eta reduce" + , ignoreHintGoldenTest + "Ignore hint in this module inserts only hlint ignore pragma if warn unrecognized pragmas is on" + "UnrecognizedPragmasOn" + (Point 3 9) + "Eta reduce" + ] + +applyHintTests :: TestTree +applyHintTests = testGroup "hlint apply hint tests" + [ + applyHintGoldenTest + "[#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + +suggestionsTests :: TestTree +suggestionsTests = + testGroup "hlint suggestions" [ + testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do + doc <- openDoc "Base.hs" "haskell" + diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + + liftIO $ do + length diags @?= 2 -- "Eta Reduce" and "Redundant Id" + reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Information + reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") + reduceDiag ^. L.source @?= Just "hlint" + + cas <- map fromAction <$> getAllCodeActions doc + + let redundantIdHintName = "Redundant id" + let etaReduceHintName = "Eta reduce" + let applyAll = find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) cas + let redId = find (\ca -> redundantIdHintName `T.isInfixOf` (ca ^. L.title)) cas + let redEta = find (\ca -> etaReduceHintName `T.isInfixOf` (ca ^. L.title)) cas + let ignoreRedundantIdInThisModule = find (\ca -> getIgnoreHintText redundantIdHintName == (ca ^.L.title)) cas + let ignoreEtaReduceThisModule = find (\ca -> getIgnoreHintText etaReduceHintName == (ca ^.L.title)) cas + + liftIO $ isJust applyAll @? "There is Apply all hints code action" + liftIO $ isJust redId @? "There is Redundant id code action" + liftIO $ isJust redEta @? "There is Eta reduce code action" + liftIO $ isJust ignoreRedundantIdInThisModule @? "There is ignore Redundant id code action" + liftIO $ isJust ignoreEtaReduceThisModule @? "There is ignore Eta reduce code action" + + executeCodeAction (fromJust redId) + + contents <- skipManyTill anyMessage $ getDocumentEdit doc + liftIO $ contents @?= "main = undefined\nfoo x = x\n" + + , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do + doc <- openDoc "Base.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "hlint" + + cars <- getAllCodeActions doc + etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] + + executeCommand etaReduce + + contents <- skipManyTill anyMessage $ getDocumentEdit doc + liftIO $ contents @?= "main = undefined\nfoo = id\n" + + , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do + doc <- openDoc "FixityUse.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do + doc <- openDoc "Base.hs" "haskell" + testHlintDiagnostics doc + + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "x" + changeDoc doc [change] + expectNoMoreDiagnostics 3 doc "hlint" + + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "id x" + + changeDoc doc [change'] + testHlintDiagnostics doc + + , testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession "cpp" $ do + doc <- openDoc "CppCond.hs" "haskell" + testHlintDiagnostics doc + + , knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $ + testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do + doc <- openDoc "CppCond.hs" "haskell" + testHlintDiagnostics doc + + , testCase "[#554] hlint diagnostics works with CPP via -XCPP argument and flag via #include header" $ runHlintSession "cpp" $ do + doc <- openDoc "CppHeader.hs" "haskell" + testHlintDiagnostics doc + + , testCase "[#590] apply-refact works with -XLambdaCase argument" $ runHlintSession "lambdacase" $ do + testRefactor "LambdaCase.hs" "Redundant bracket" + expectedLambdaCase + + , testCase "[#1242] apply-refact works with -XTypeApplications argument" $ runHlintSession "typeapps" $ do + testRefactor "TypeApplication.hs" "Redundant bracket" + expectedTypeApp + + , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do + testRefactor "LambdaCase.hs" "Redundant bracket" + ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do + testRefactor "CppCond.hs" "Redundant bracket" + expectedCPP + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do + testRefactor "CppCond.hs" "Redundant bracket" + ("{-# LANGUAGE CPP #-}" : expectedCPP) + + , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do + doc <- openDoc "CamelCase.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do + doc <- openDoc "IgnoreAnn.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do + doc <- openDoc "IgnoreAnnHlint.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do + testRefactor "Comments.hs" "Redundant bracket" expectedComments + + , testCase "[#2290] apply all hints works with a trailing comment" $ runHlintSession "" $ do + testRefactor "TwoHintsAndComment.hs" "Apply all hints" expectedComments2 + + , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do + doc <- openDoc "TwoHints.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "hlint" + + firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) + secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) + thirdLine <- map fromAction <$> getCodeActions doc (mkRange 2 0 2 0) + multiLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 2 0) + + let hasApplyAll = isJust . find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) + + liftIO $ hasApplyAll firstLine @? "Missing apply all code action" + liftIO $ hasApplyAll secondLine @? "Missing apply all code action" + liftIO $ not (hasApplyAll thirdLine) @? "Unexpected apply all code action" + liftIO $ hasApplyAll multiLine @? "Missing apply all code action" + + , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do + doc <- openDoc "UnusedExtension.hs" "haskell" + diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint" + + liftIO $ do + length diags @?= 1 + unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma") + + , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do + doc <- openDoc "PatternKeyword.hs" "haskell" + + waitForAllProgressDone + -- hlint will report a parse error if PatternSynonyms is enabled + expectNoMoreDiagnostics 3 doc "hlint" + , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do + doc <- openDoc "StrictData.hs" "haskell" + + waitForAllProgressDone + + expectNoMoreDiagnostics 3 doc "hlint" + ] + where + testRefactor file caTitle expected = do + doc <- openDoc file "haskell" + testHlintDiagnostics doc + + cas <- map fromAction <$> getAllCodeActions doc + let ca = find (\ca -> caTitle `T.isInfixOf` (ca ^. L.title)) cas + liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action") + + executeCodeAction (fromJust ca) + + contents <- skipManyTill anyMessage $ getDocumentEdit doc + liftIO $ contents @?= T.unlines expected + + expectedLambdaCase = [ "module LambdaCase where", "" + , "f = \\case \"true\" -> True" + , " _ -> False" + ] + expectedCPP = [ "module CppCond where", "" + , "#ifdef FLAG" + , "f = 1" + , "#else" + , "g = 2" + , "#endif", "" + ] + expectedComments = [ "-- comment before header" + , "module Comments where", "" + , "{-# standalone annotation #-}", "" + , "-- standalone comment", "" + , "-- | haddock comment" + , "f = {- inline comment -} {- inline comment inside refactored code -}1 -- ending comment", "" + , "-- final comment" + ] + expectedComments2 = [ "module TwoHintsAndComment where" + , "biggest = foldr1 max -- the line above will show two hlint hints, \"eta reduce\" and \"use maximum\"" + ] + expectedTypeApp = [ "module TypeApplication where", "" + , "a = id @Int 1" + ] + + +configTests :: TestTree +configTests = testGroup "hlint plugin config" [ + + testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False + enableHlint + + doc <- openDoc "Base.hs" "haskell" + testHlintDiagnostics doc + + disableHlint + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False + enableHlint + + doc <- openDoc "Base.hs" "haskell" + testHlintDiagnostics doc + + let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"] + setHlsConfig config' + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False + enableHlint + + doc <- openDoc "Generalise.hs" "haskell" + + expectNoMoreDiagnostics 3 doc "hlint" + + let config' = hlintConfigWithFlags ["--with-group=generalise"] + setHlsConfig config' + + diags' <- waitForDiagnosticsFromSource doc "hlint" + d <- liftIO $ inspectDiagnostic diags' ["Use <>"] + + liftIO $ do + length diags' @?= 1 + d ^. L.range @?= Range (Position 1 10) (Position 1 21) + d ^. L.severity @?= Just DiagnosticSeverity_Information + ] + +testDir :: FilePath +testDir = "plugins/hls-hlint-plugin/test/testdata" + +runHlintSession :: FilePath -> Session a -> IO a +runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) + +noHlintDiagnostics :: [Diagnostic] -> Assertion +noHlintDiagnostics diags = + Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + +testHlintDiagnostics :: TextDocumentIdentifier -> Session () +testHlintDiagnostics doc = do + diags <- waitForDiagnosticsFromSource doc "hlint" + liftIO $ length diags > 0 @? "There are hlint diagnostics" + +hlintConfigWithFlags :: [T.Text] -> Config +hlintConfigWithFlags flags = + def + { Plugin.plugins = Map.fromList [("hlint", + def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object ["flags" .= flags] } + )] } + where + unObject (Object obj) = obj + unObject _ = undefined + +enableHlint :: Session () +enableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = True }) ] } + +disableHlint :: Session () +disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = False }) ] } + +-- We have two main code paths in the plugin depending on how hlint interacts with ghc: +-- * One when hlint uses ghc-lib (all ghc versions but the last version supported by hlint) +-- * Another one when hlint uses directly ghc (only one version, which not have to be the last version supported by ghcide) +-- As we always are using ghc through ghcide the code to get the ghc parsed AST differs +-- So the issues and bugs usually only affects to one code path or the other. +-- Although a given hlint version supports one direct ghc, we could use several versions of hlint +-- each one supporting a different ghc version. It should be a temporary situation though. +knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree +knownBrokenForHlintOnGhcLib = expectFailBecause + +-- 1's based +data Point = Point { + line :: !Int, + column :: !Int +} + +pointToRange :: Point -> Range +pointToRange Point {..} + | line <- fromIntegral $ subtract 1 line + , column <- fromIntegral $ subtract 1 column = + Range (Position line column) (Position line $ column + 1) + +getCodeActionTitle :: (Command |? CodeAction) -> Maybe T.Text +getCodeActionTitle commandOrCodeAction + | InR CodeAction {_title} <- commandOrCodeAction = Just _title + | otherwise = Nothing + +makeCodeActionNotFoundAtString :: Point -> String +makeCodeActionNotFoundAtString Point {..} = + "CodeAction not found at line: " <> show line <> ", column: " <> show column + +ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenTest testCaseName goldenFilename point hintName = + goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenTest testCaseName goldenFilename point hintName = do + goldenTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenTest testCaseName goldenFilename point hintText = + setupGoldenHlintTest testCaseName goldenFilename $ \document -> do + _ <- waitForDiagnosticsFromSource document "hlint" + actions <- getCodeActions document $ pointToRange point + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> do + executeCodeAction codeAction + when (isJust (codeAction ^. L.command)) $ + void $ skipManyTill anyMessage $ getDocumentEdit document + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintTest testName path = + goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + +ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = + goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do + goldenResolveTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenResolveTest testCaseName goldenFilename point hintText = + setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do + _ <- waitForDiagnosticsFromSource document "hlint" + actions <- getAndResolveCodeActions document $ pointToRange point + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> executeCodeAction codeAction + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintResolveTest testName path = + goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" diff --git a/plugins/hls-hlint-plugin/test/testdata/Base.hs b/plugins/hls-hlint-plugin/test/testdata/Base.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/Base.hs @@ -0,0 +1,2 @@ +main = undefined +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/Comments.hs b/plugins/hls-hlint-plugin/test/testdata/Comments.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/Comments.hs @@ -0,0 +1,11 @@ +-- comment before header +module Comments where + +{-# standalone annotation #-} + +-- standalone comment + +-- | haddock comment +f = {- inline comment -} ({- inline comment inside refactored code -}1) -- ending comment + +-- final comment diff --git a/plugins/hls-hlint-plugin/test/testdata/CppCond.hs b/plugins/hls-hlint-plugin/test/testdata/CppCond.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/CppCond.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module CppCond where + +#ifdef FLAG +f = (1) +#else +g = 2 +#endif diff --git a/plugins/hls-hlint-plugin/test/testdata/Generalise.hs b/plugins/hls-hlint-plugin/test/testdata/Generalise.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/Generalise.hs @@ -0,0 +1,2 @@ +main = undefined +foo x y = [x, x] ++ y diff --git a/plugins/hls-hlint-plugin/test/testdata/IgnoreAnn.hs b/plugins/hls-hlint-plugin/test/testdata/IgnoreAnn.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/IgnoreAnn.hs @@ -0,0 +1,5 @@ +module IgnoreAnn where + +{-# ANN module "HLint: ignore Redundant bracket" #-} +f = (1) + diff --git a/plugins/hls-hlint-plugin/test/testdata/IgnoreAnnHlint.hs b/plugins/hls-hlint-plugin/test/testdata/IgnoreAnnHlint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/IgnoreAnnHlint.hs @@ -0,0 +1,7 @@ +module IgnoreHlintAnn where + +{- HLINT ignore "Redundant bracket" -} +f = (1) + +{-# HLINT ignore "Use camelCase" #-} +camel_case = undefined diff --git a/plugins/hls-hlint-plugin/test/testdata/LambdaCase.hs b/plugins/hls-hlint-plugin/test/testdata/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/LambdaCase.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +module LambdaCase where + +f = \case "true" -> (True) + _ -> False diff --git a/plugins/hls-hlint-plugin/test/testdata/PatternKeyword.hs b/plugins/hls-hlint-plugin/test/testdata/PatternKeyword.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/PatternKeyword.hs @@ -0,0 +1,3 @@ +module Foo (pattern) where + +pattern = 42 diff --git a/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = sortOn (Down . snd) . map (head &&& length) . id diff --git a/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = reverse . sortOn snd . map (head &&& length) . id diff --git a/plugins/hls-hlint-plugin/test/testdata/StrictData.hs b/plugins/hls-hlint-plugin/test/testdata/StrictData.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/StrictData.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE Strict #-} +f ~x = x diff --git a/plugins/hls-hlint-plugin/test/testdata/TwoHints.hs b/plugins/hls-hlint-plugin/test/testdata/TwoHints.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/TwoHints.hs @@ -0,0 +1,2 @@ +f = (1) +g = (1) diff --git a/plugins/hls-hlint-plugin/test/testdata/TwoHintsAndComment.hs b/plugins/hls-hlint-plugin/test/testdata/TwoHintsAndComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/TwoHintsAndComment.hs @@ -0,0 +1,2 @@ +module TwoHintsAndComment where +biggest items = foldr1 max items -- the line above will show two hlint hints, "eta reduce" and "use maximum" diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} +module UnrecognizedPragmasOff where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +module UnrecognizedPragmasOff where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wunrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} +module UnrecognizedPragmasOn where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wunrecognised-pragmas #-} +module UnrecognizedPragmasOn where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/cpp/CppCond.hs b/plugins/hls-hlint-plugin/test/testdata/cpp/CppCond.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/cpp/CppCond.hs @@ -0,0 +1,7 @@ +module ApplyRefact3 where + +#ifdef FLAG +f = (1) +#else +g = 2 +#endif diff --git a/plugins/hls-hlint-plugin/test/testdata/cpp/CppHeader.hs b/plugins/hls-hlint-plugin/test/testdata/cpp/CppHeader.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/cpp/CppHeader.hs @@ -0,0 +1,9 @@ +module CppHeader where + +#include "test.h" + +#ifdef TEST +f = (1) +#else +f = 1 +#endif diff --git a/plugins/hls-hlint-plugin/test/testdata/cpp/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/cpp/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/cpp/hie.yaml @@ -0,0 +1,7 @@ +cradle: + direct: + arguments: + - "-XCPP" + - "-DFLAG" + - "CppCond" + - "CppHeader" diff --git a/plugins/hls-hlint-plugin/test/testdata/fixity/FixityDef.hs b/plugins/hls-hlint-plugin/test/testdata/fixity/FixityDef.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/fixity/FixityDef.hs @@ -0,0 +1,5 @@ +module FixityDef where + +infixl 3 +() :: Maybe a -> Maybe (Maybe b) -> Maybe String +() a b = Nothing diff --git a/plugins/hls-hlint-plugin/test/testdata/fixity/FixityUse.hs b/plugins/hls-hlint-plugin/test/testdata/fixity/FixityUse.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/fixity/FixityUse.hs @@ -0,0 +1,6 @@ +module FixityUse where + +import FixityDef + +foo :: Char -> Maybe Int -> Maybe String +foo c mInt = show <$> mInt pure <$> Just c diff --git a/plugins/hls-hlint-plugin/test/testdata/fixity/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/fixity/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/fixity/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - "FixityDef" + - "FixityUse" + diff --git a/plugins/hls-hlint-plugin/test/testdata/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/hie.yaml @@ -0,0 +1,16 @@ +cradle: + direct: + arguments: + - "-DFLAG" + - "-Wno-unrecognised-pragmas" + - "Base" + - "Comments" + - "CppCond" + - "Generalise" + - "IgnoreAnn" + - "IgnoreAnnHlint" + - "LambdaCase" + - "TwoHints" + - "PatternKeyword" + - "StrictData" + - "TwoHintsAndComment" diff --git a/plugins/hls-hlint-plugin/test/testdata/ignore/CamelCase.hs b/plugins/hls-hlint-plugin/test/testdata/ignore/CamelCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/ignore/CamelCase.hs @@ -0,0 +1,5 @@ +module CamelCase where + +f = (1) + +camel_case = undefined diff --git a/plugins/hls-hlint-plugin/test/testdata/ignore/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/ignore/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/ignore/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "CamelCase" diff --git a/plugins/hls-hlint-plugin/test/testdata/lambdacase/LambdaCase.hs b/plugins/hls-hlint-plugin/test/testdata/lambdacase/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/lambdacase/LambdaCase.hs @@ -0,0 +1,4 @@ +module LambdaCase where + +f = \case "true" -> (True) + _ -> False diff --git a/plugins/hls-hlint-plugin/test/testdata/lambdacase/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/lambdacase/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/lambdacase/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "-XLambdaCase" + - "LambdaCase" diff --git a/plugins/hls-hlint-plugin/test/testdata/test-hlint-config.yaml b/plugins/hls-hlint-plugin/test/testdata/test-hlint-config.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/test-hlint-config.yaml @@ -0,0 +1,1 @@ +- ignore: { name: Eta reduce } diff --git a/plugins/hls-hlint-plugin/test/testdata/typeapps/TypeApplication.hs b/plugins/hls-hlint-plugin/test/testdata/typeapps/TypeApplication.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/typeapps/TypeApplication.hs @@ -0,0 +1,3 @@ +module TypeApplication where + +a = (id @Int 1) diff --git a/plugins/hls-hlint-plugin/test/testdata/typeapps/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/typeapps/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/typeapps/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "-XTypeApplications" + - "TypeApplications" diff --git a/plugins/hls-hlint-plugin/test/testdata/unusedext/UnusedExtension.hs b/plugins/hls-hlint-plugin/test/testdata/unusedext/UnusedExtension.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/unusedext/UnusedExtension.hs @@ -0,0 +1,1 @@ +{-# LANGUAGE BangPatterns #-} diff --git a/plugins/hls-hlint-plugin/test/testdata/unusedext/hie.yaml b/plugins/hls-hlint-plugin/test/testdata/unusedext/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/unusedext/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "UnusedExtension" diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults #-} + +{- | Keep the module name in sync with its file path. + +Provide CodeLenses to: +* Add a module header ("module /moduleName/ where") to empty Haskell files +* Fix the module name if incorrect +-} +module Ide.Plugin.ModuleName ( + descriptor, + Log, +) where + +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson (toJSON) +import Data.Char (isLower, isUpper) +import Data.List (intercalate, minimumBy, + stripPrefix, uncons) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), + IdeState, Pretty, + Priority (Debug), + Recorder, WithPriority, + colon, evalGhcEnv, + hscEnvWithImportPaths, + logWith, + realSrcSpanToRange, + runAction, useWithStale, + (<+>)) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.GHC.Compat (GenLocated (L), + getSessionDynFlags, + hsmodName, importPaths, + locA, moduleNameString, + pattern RealSrcSpan, + pm_parsed_source, unLoc) +import Ide.Logger (Pretty (..)) +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server +import Language.LSP.VFS (virtualFileText) +import System.Directory (makeAbsolute) +import System.FilePath (dropExtension, normalise, + pathSeparator, + splitDirectories, + takeFileName) + +-- |Plugin descriptor +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId "Provides a code action to alter the module name if it is wrong") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (codeLens recorder) + , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)] + } + +updateModuleNameCommand :: IsString p => p +updateModuleNameCommand = "updateModuleName" + +-- | Generate code lenses +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens +codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + res <- action recorder state uri + pure $ InL (asCodeLens <$> res) + where + asCodeLens :: Action -> CodeLens + asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing + where + cmd = mkLspCommand pluginId updateModuleNameCommand aTitle (Just [toJSON aUri]) + +-- | (Quasi) Idempotent command execution: recalculate action to execute on command request +command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri +command recorder state _ uri = do + actMaybe <- action recorder state uri + forM_ actMaybe $ \Replace{..} -> + let + -- | Convert an Action to the corresponding edit operation + edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing + in + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) + pure $ InR Null + +-- | A source code change +data Action = Replace + { aUri :: Uri + , aRange :: Range + , aTitle :: T.Text + , aCode :: T.Text + } + deriving (Show) + +-- | Required action (that can be converted to either CodeLenses or CodeActions) +action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action] +action recorder state uri = do + nfp <- getNormalizedFilePathE uri + fp <- uriToFilePathE uri + + contents <- lift . getVirtualFile $ toNormalizedUri uri + let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents + + correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp + logWith recorder Debug (CorrectNames correctNames) + let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames + logWith recorder Debug (BestName bestName) + + statedNameMaybe <- liftIO $ codeModuleName state nfp + logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe) + case (bestName, statedNameMaybe) of + (Just bestName, Just (nameRange, statedName)) + | statedName `notElem` correctNames -> + pure [Replace uri nameRange ("Set module name to " <> bestName) bestName] + (Just bestName, Nothing) + | emptyModule -> + let code = "module " <> bestName <> " where\n" + in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code] + _ -> pure [] + +-- | Possible module names, as derived by the position of the module in the +-- source directories. There may be more than one possible name, if the source +-- directories are nested inside each other. +pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text] +pathModuleNames recorder state normFilePath filePath + | isLower . head $ takeFileName filePath = return ["Main"] + | otherwise = do + (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath + srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags + logWith recorder Debug (SrcPaths srcPaths) + + -- Append a `pathSeparator` to make the path looks like a directory, + -- and then we can drop it uniformly. + -- See https://github.com/haskell/haskell-language-server/pull/3092 for details. + let paths = map (normalise . (<> pure pathSeparator)) srcPaths + logWith recorder Debug (NormalisedPaths paths) + + mdlPath <- liftIO $ makeAbsolute filePath + logWith recorder Debug (AbsoluteFilePath mdlPath) + + let suffixes = mapMaybe (`stripPrefix` mdlPath) paths + pure (map moduleNameFrom suffixes) + where + moduleNameFrom = + T.pack + . intercalate "." + -- Do not suggest names whose components start from a lower-case char, + -- they are guaranteed to be malformed. + . filter (maybe False (isUpper . fst) . uncons) + . splitDirectories + . dropExtension + +-- | The module name, as stated in the module +codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) +codeModuleName state nfp = runMaybeT $ do + (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp + L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm + range <- MaybeT . pure $ toCurrentRange mp (realSrcSpanToRange l) + pure (range, T.pack $ moduleNameString m) + +data Log = + CorrectNames [T.Text] + | BestName (Maybe T.Text) + | ModuleName (Maybe T.Text) + | SrcPaths [FilePath] + | NormalisedPaths [FilePath] + | AbsoluteFilePath FilePath + deriving Show + +instance Pretty Log where + pretty log = "ModuleName." <> case log of + CorrectNames log -> "CorrectNames" <> colon <+> pretty log + BestName log -> "BestName" <> colon <+> pretty log + ModuleName log -> "StatedNameMaybe" <> colon <+> pretty log + SrcPaths log -> "SrcPaths" <> colon <+> pretty log + NormalisedPaths log -> "NormalisedPaths" <> colon <+> pretty log + AbsoluteFilePath log -> "AbsoluteFilePath" <> colon <+> pretty log diff --git a/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import Control.Monad (void) +import qualified Ide.Plugin.ModuleName as ModuleName +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +moduleNamePlugin :: PluginTestDescriptor ModuleName.Log +moduleNamePlugin = mkPluginTestDescriptor ModuleName.descriptor "moduleName" + +tests :: TestTree +tests = + testGroup "moduleName" + [ goldenWithModuleName "Add module header to empty module" "TEmptyModule" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + + , goldenWithModuleName "Fix wrong module name" "TWrongModuleName" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + + , goldenWithModuleName "Must infer module name as Main, if the file name starts with a lowercase" "mainlike" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + + , goldenWithModuleName "Fix wrong module name in nested directory" "subdir/TWrongModuleName" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + , testCase "Should not show code lens if the module name is correct" $ + runSessionWithServer def moduleNamePlugin testDataDir $ do + doc <- openDoc "CorrectName.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ lenses @?= [] + closeDoc doc + -- https://github.com/haskell/haskell-language-server/issues/3047 + , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + , testCase "Keep stale lens even if parse failed" $ do + runSessionWithServer def moduleNamePlugin testDataDir $ do + doc <- openDoc "Stale.hs" "haskell" + oldLens <- getCodeLenses doc + let edit = TextEdit (mkRange 1 0 1 0) "f =" + _ <- applyEdit doc edit + newLens <- getCodeLenses doc + liftIO $ newLens @?= oldLens + closeDoc doc + ] + +goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithModuleName title path = goldenWithHaskellDoc def moduleNamePlugin title testDataDir path "expected" "hs" + +testDataDir :: FilePath +testDataDir = "plugins" "hls-module-name-plugin" "test" "testdata" diff --git a/plugins/hls-module-name-plugin/test/testdata/CorrectName.hs b/plugins/hls-module-name-plugin/test/testdata/CorrectName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/CorrectName.hs @@ -0,0 +1,1 @@ +module CorrectName where diff --git a/plugins/hls-module-name-plugin/test/testdata/Stale.hs b/plugins/hls-module-name-plugin/test/testdata/Stale.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/Stale.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.expected.hs b/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.expected.hs @@ -0,0 +1,3 @@ +module TEmptyModule where + + diff --git a/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.hs b/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/TEmptyModule.hs @@ -0,0 +1,2 @@ + + diff --git a/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.expected.hs b/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.expected.hs @@ -0,0 +1,7 @@ +module TWrongModuleName + ( x + ) +where + +x :: Integer +x = 11 diff --git a/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.hs b/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/TWrongModuleName.hs @@ -0,0 +1,7 @@ +module BadName + ( x + ) +where + +x :: Integer +x = 11 diff --git a/plugins/hls-module-name-plugin/test/testdata/cabal.project b/plugins/hls-module-name-plugin/test/testdata/cabal.project new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/cabal.project @@ -0,0 +1,1 @@ +packages: ./canonicalize diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs @@ -0,0 +1,1 @@ +module Lib.A where diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal b/plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.4 +name: canonicalize +version: 0.1.0.0 + +library + build-depends: base + hs-source-dirs: ./ diff --git a/plugins/hls-module-name-plugin/test/testdata/hie.yaml b/plugins/hls-module-name-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/hie.yaml @@ -0,0 +1,17 @@ +cradle: + multi: + - path: "./" + config: + cradle: + direct: + arguments: + - "-isubdir" + - "TEmptyModule" + - "TWrongModuleName" + - "CorrectName" + - path: "./canonicalize" + config: + cradle: + cabal: + - path: "./" + component: "lib:canonicalize" diff --git a/plugins/hls-module-name-plugin/test/testdata/mainlike.expected.hs b/plugins/hls-module-name-plugin/test/testdata/mainlike.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/mainlike.expected.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/plugins/hls-module-name-plugin/test/testdata/mainlike.hs b/plugins/hls-module-name-plugin/test/testdata/mainlike.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/mainlike.hs diff --git a/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.expected.hs b/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.expected.hs @@ -0,0 +1,7 @@ +module TWrongModuleName + ( x + ) +where + +x :: Integer +x = 11 diff --git a/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.hs b/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/subdir/TWrongModuleName.hs @@ -0,0 +1,7 @@ +module BadName + ( x + ) +where + +x :: Integer +x = 11 diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Ormolu + ( descriptor + , provider + , LogEvent + ) +where + +import Control.Exception (Handler (..), IOException, + SomeException (..), catches, + handle) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Extra +import Control.Monad.Trans +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT) +import Data.Functor ((<&>)) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) +import qualified Development.IDE.GHC.Compat as D +import qualified Development.IDE.GHC.Compat.Util as S +import GHC.LanguageExtensions.Type +import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.Plugin.Properties +import Ide.PluginUtils +import Ide.Types hiding (Config) +import qualified Ide.Types as Types +import Language.LSP.Protocol.Types +import Language.LSP.Server hiding (defaultConfig) +import Ormolu +import System.Exit +import System.FilePath +import System.Process.Run (cwd, proc) +import System.Process.Text (readCreateProcessWithExitCode) +import Text.Read (readMaybe) + +-- --------------------------------------------------------------------- + +descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers $ provider recorder plId, + pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} + } + where + desc = "Provides formatting of Haskell files via ormolu. Built with ormolu-" <> VERSION_ormolu + +properties :: Properties '[ 'PropertyKey "external" 'TBoolean] +properties = + emptyProperties + & defineBooleanProperty + #external + "Call out to an external \"ormolu\" executable, rather than using the bundled library" + False + +-- --------------------------------------------------------------------- + +provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState +provider recorder plId ideState token typ contents fp _ = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do + fileOpts <- + maybe [] (fromDyn . hsc_dflags . hscEnv) + <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp) + useCLI <- liftIO $ runAction "Ormolu" ideState $ usePropertyAction #external plId properties + + if useCLI + then mapExceptT liftIO $ ExceptT + $ handle @IOException + (pure . Left . PluginInternalError . T.pack . show) + $ runExceptT $ cliHandler fileOpts + else do + logWith recorder Debug $ LogCompiledInVersion VERSION_ormolu + + let + fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text) + fmt cont conf = flip catches handlers $ do +#if MIN_VERSION_ormolu(0,5,3) + cabalInfo <- getCabalInfoForSourceFile fp' <&> \case + CabalNotFound -> Nothing + CabalDidNotMention cabalInfo -> Just cabalInfo + CabalFound cabalInfo -> Just cabalInfo +#if MIN_VERSION_ormolu(0,7,0) + (fixityOverrides, moduleReexports) <- getDotOrmoluForSourceFile fp' + let conf' = refineConfig ModuleSource cabalInfo (Just fixityOverrides) (Just moduleReexports) conf +#else + fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo + let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf +#endif + let cont' = cont +#else + let conf' = conf + cont' = T.unpack cont +#endif + Right <$> ormolu conf' fp' cont' + handlers = + [ Handler $ pure . Left . SomeException @OrmoluException + , Handler $ pure . Left . SomeException @IOException + ] + + res <- liftIO $ fmt contents defaultConfig { cfgDynOptions = map DynOption fileOpts, cfgRegion = region } + ret res + where + fp' = fromNormalizedFilePath fp + + region :: RegionIndices + region = case typ of + FormatText -> + RegionIndices Nothing Nothing + FormatRange (Range (Position sl _) (Position el _)) -> + RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1) + + title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) + + ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null) + ret (Left err) = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err + ret (Right new) = pure $ InL $ makeDiffTextEdit contents new + + fromDyn :: D.DynFlags -> [String] + fromDyn df = + let + pp = + let p = D.sPgm_F $ D.settings df + in ["-pgmF=" <> p | not (null p)] + pm = ("-fplugin=" <>) . moduleNameString <$> D.pluginModNames df + ex = showExtension <$> S.toList (D.extensionFlags df) + in pp <> pm <> ex + + cliHandler :: [String] -> ExceptT PluginError IO ([TextEdit] |? Null) + cliHandler fileOpts = do + CLIVersionInfo{noCabal} <- do -- check Ormolu version so that we know which flags to use + (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc "ormolu" ["--version"] ) "" + let version = do + guard $ exitCode == ExitSuccess + "ormolu" : v : _ <- pure $ T.words out + traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v + case version of + Just v -> do + logWith recorder Debug $ LogExternalVersion v + pure CLIVersionInfo + { noCabal = v >= [0, 7] + } + Nothing -> do + logWith recorder Debug $ LogExternalVersion [] + logWith recorder Warning $ NoVersion out + pure CLIVersionInfo + { noCabal = True + } + (exitCode, out, err) <- do -- run Ormolu + let commandArgs = map ("-o" <>) fileOpts + -- "The --stdin-input-file option is necessary when using input from + -- stdin and accounting for .cabal files" as per Ormolu documentation + <> (if noCabal then ["--no-cabal"] else ["--stdin-input-file", fp']) + <> catMaybes + [ ("--start-line=" <>) . show <$> regionStartLine region + , ("--end-line=" <>) . show <$> regionEndLine region + ] + cwd = takeDirectory fp' + logWith recorder Debug $ LogOrmoluCommand commandArgs cwd + liftIO $ readCreateProcessWithExitCode (proc "ormolu" commandArgs) {cwd = Just cwd} contents + case exitCode of + ExitSuccess -> do + when (not $ T.null err) $ logWith recorder Debug $ StdErr err + pure $ InL $ makeDiffTextEdit contents out + ExitFailure n -> do + logWith recorder Info $ StdErr err + throwError $ PluginInternalError $ "Ormolu failed with exit code " <> T.pack (show n) + +newtype CLIVersionInfo = CLIVersionInfo + { noCabal :: Bool + } + +data LogEvent + = NoVersion Text + | StdErr Text + | LogCompiledInVersion String + | LogExternalVersion [Int] + | LogOrmoluCommand [String] FilePath + deriving (Show) + +instance Pretty LogEvent where + pretty = \case + NoVersion t -> "Couldn't get Ormolu version:" <> line <> indent 2 (pretty t) + StdErr t -> "Ormolu stderr:" <> line <> indent 2 (pretty t) + LogCompiledInVersion v -> "Using compiled in ormolu-" <> pretty v + LogExternalVersion v -> + "Using external ormolu" + <> if null v then "" else "-" + <> pretty (intercalate "." $ map show v) + LogOrmoluCommand commandArgs cwd -> "Running: `ormolu " <> pretty (unwords commandArgs) <> "` in directory " <> pretty cwd + +showExtension :: Extension -> String +showExtension Cpp = "-XCPP" +showExtension other = "-X" ++ show other diff --git a/plugins/hls-ormolu-plugin/test/Main.hs b/plugins/hls-ormolu-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/Main.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Functor +import Ide.Plugin.Config +import qualified Ide.Plugin.Ormolu as Ormolu +import Language.LSP.Protocol.Types +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +ormoluPlugin :: PluginTestDescriptor Ormolu.LogEvent +ormoluPlugin = mkPluginTestDescriptor Ormolu.descriptor "ormolu" + +tests :: TestTree +tests = testGroup "ormolu" $ + [False, True] <&> \cli -> + testGroup (if cli then "cli" else "lib") + [ goldenWithOrmolu cli "formats correctly" "Ormolu" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) + , goldenWithOrmolu cli "formats imports correctly" "Ormolu2" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) +#if MIN_VERSION_ormolu(0,5,3) + , goldenWithOrmolu cli "formats operators correctly" "Ormolu3" "formatted" $ \doc -> do + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) +#endif + ] + +goldenWithOrmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithOrmolu cli title path desc = + goldenWithHaskellDocFormatter def ormoluPlugin "ormolu" conf title testDataDir path desc "hs" + where + conf = def{plcConfig = KM.fromList ["external" .= cli]} + +testDataDir :: FilePath +testDataDir = "plugins" "hls-ormolu-plugin" "test" "testdata" diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu.expected.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.expected.hs @@ -0,0 +1,16 @@ +module Ormolu where + +import Data.Int +import Data.List +import Prelude + +foo :: Int -> Int +foo 3 = 2 +foo x = x + +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz {a :: Int, b :: String} diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu.formatted.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.formatted.hs @@ -0,0 +1,16 @@ +module Ormolu where + +import Data.Int +import Data.List +import Prelude + +foo :: Int -> Int +foo 3 = 2 +foo x = x + +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz {a :: Int, b :: String} diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu.hs @@ -0,0 +1,15 @@ +module Ormolu where +import Data.List + +import Prelude +import Data.Int +foo :: Int -> Int +foo 3 = 2 +foo x = x +bar :: String -> IO String +bar s = do + x <- return "hello" + return "asdf" + +data Baz = Baz { a :: Int, b :: String } + diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.expected.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.expected.hs @@ -0,0 +1,5 @@ +import Data.Bool +import Data.Char +import Data.Data +import Data.Either +import Data.Int diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.formatted.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.formatted.hs @@ -0,0 +1,5 @@ +import Data.Bool +import Data.Char +import Data.Data +import Data.Either +import Data.Int diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu2.hs @@ -0,0 +1,5 @@ +import Data.Char +import Data.Either +import Data.Int +import Data.Data +import Data.Bool diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.expected.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.expected.hs @@ -0,0 +1,5 @@ +foo :: String +foo = + "a" .=? "b" + <> "c" .=? "d" + <> "e" .=? "f" diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.formatted.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.formatted.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.formatted.hs @@ -0,0 +1,5 @@ +foo :: String +foo = + "a" .=? "b" + <> "c" .=? "d" + <> "e" .=? "f" diff --git a/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.hs b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/Ormolu3.hs @@ -0,0 +1,3 @@ +foo :: String +foo = "a" .=? "b" + <> "c" .=? "d" <> "e" .=? "f" diff --git a/plugins/hls-ormolu-plugin/test/testdata/hie.yaml b/plugins/hls-ormolu-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-ormolu-plugin/test/testdata/test.cabal b/plugins/hls-ormolu-plugin/test/testdata/test.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-ormolu-plugin/test/testdata/test.cabal @@ -0,0 +1,3 @@ +cabal-version: 3.0 +name: test +version: 0 diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.OverloadedRecordDot + ( descriptor + , Log + ) where + +-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin + +import Control.Lens ((^.)) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Generics (GenericQ, everythingBut, + mkQ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Maybe (mapMaybe, maybeToList) +import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) +import Development.IDE (IdeState, + NormalizedFilePath, + Pretty (..), Range, + Recorder (..), Rules, + WithPriority (..), + realSrcSpanToRange) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import Development.IDE.Core.Shake (define, useWithStale) +import qualified Development.IDE.Core.Shake as Shake + +#if __GLASGOW_HASKELL__ >= 903 +import Development.IDE.GHC.Compat (HsExpr (HsRecSel)) +#else +import Development.IDE.GHC.Compat (HsExpr (HsRecFld)) +#endif + +import Control.DeepSeq (rwhnf) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (PositionMapping, + toCurrentRange) +import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), + GhcPass, + HsExpansion (HsExpanded), + HsExpr (HsApp, HsVar, OpApp, XExpr), + LHsExpr, Pass (..), + appPrec, dollarName, + getLoc, hs_valds, + parenthesizeHsExpr, + pattern RealSrcSpan, + unLoc) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), + cmapWithPrio, logWith, + (<+>)) +import Ide.Plugin.Error (PluginError (..), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + ResolveFunction, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), + CodeActionParams (..), + TextEdit (..), Uri (..), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (..)) + +data Log + = LogShake Shake.Log + | LogCollectedRecordSelectors [RecordSelectorExpr] + | forall a. (Pretty a) => LogResolve a + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCollectedRecordSelectors recs -> "Collected record selectors:" + <+> pretty recs + LogResolve msg -> pretty msg + +data CollectRecordSelectors = CollectRecordSelectors + deriving (Eq, Show, Generic) + +instance Hashable CollectRecordSelectors +instance NFData CollectRecordSelectors + +data CollectRecordSelectorsResult = CRSR + { -- |We store everything in here that we need to create the unresolved + -- codeAction: the range, an uniquely identifiable int, and the selector + --selector expression (HSExpr) that we use to generate the name + records :: RangeMap (Int, HsExpr (GhcPass 'Renamed)) + -- |This is for when we need to fully generate a textEdit. It contains the + -- whole expression we are interested in indexed to the unique id we got + -- from the previous field + , recordInfos :: IntMap.IntMap RecordSelectorExpr + , enabledExtensions :: [Extension] + } + deriving (Generic) + +instance NFData CollectRecordSelectorsResult + +instance Show CollectRecordSelectorsResult where + show _ = "" + +type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult + +-- |Where we store our collected record selectors +data RecordSelectorExpr = RecordSelectorExpr + { -- |The location of the matched expression + location :: Range, + -- |The record selector, this is found in front of recordExpr, but get's + -- placed after it when converted into record dot syntax + selectorExpr :: LHsExpr (GhcPass 'Renamed), + -- |The record expression. The only requirement is that it evaluates to a + -- record in the end + recordExpr :: LHsExpr (GhcPass 'Renamed) } + +instance Pretty RecordSelectorExpr where + pretty (RecordSelectorExpr _ rs se) = pretty (printOutputable rs) <> ":" + <+> pretty (printOutputable se) + +instance NFData RecordSelectorExpr where + rnf = rwhnf + +-- |The data that is serialized and placed in the data field of resolvable +-- code actions +data ORDResolveData = ORDRD { + -- |We need the uri to get shake results + uri :: Uri + -- |The unique id that allows us to find the specific codeAction we want +, uniqueID :: Int +} deriving (Generic, Show) +instance ToJSON ORDResolveData +instance FromJSON ORDResolveData + +descriptor :: Recorder (WithPriority Log) -> PluginId + -> PluginDescriptor IdeState +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + pluginHandler = mkCodeActionHandlerWithResolve resolveRecorder codeActionProvider resolveProvider + in (defaultPluginDescriptor plId "Provides a code action to convert record selector usage to use overloaded record dot syntax") + { pluginHandlers = pluginHandler + , pluginRules = collectRecSelsRule recorder + } + +resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve +resolveProvider ideState plId ca uri (ORDRD _ int) = + do + nfp <- getNormalizedFilePathE uri + CRSR _ crsDetails exts <- collectRecSelResult ideState nfp + pragma <- getFirstPragma plId ideState nfp + rse <- handleMaybe PluginStaleResolve $ IntMap.lookup int crsDetails + pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} + +codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider ideState _ (CodeActionParams _ _ caDocId caRange _) = + do + nfp <- getNormalizedFilePathE (caDocId ^. L.uri) + CRSR crsMap _ exts <- collectRecSelResult ideState nfp + let mkCodeAction (crsM, nse) = InR CodeAction + { -- We pass the record selector to the title function, so that + -- we can have the name of the record selector in the title of + -- the codeAction. This allows the user can easily distinguish + -- between the different codeActions when using nested record + -- selectors, the disadvantage is we need to print out the + -- name of the record selector which will decrease performance + _title = mkCodeActionTitle exts nse + , _kind = Just CodeActionKind_RefactorRewrite + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Nothing + , _command = Nothing + , _data_ = Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM + } + actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) + pure $ InL actions + where + mkCodeActionTitle :: [Extension] -> HsExpr (GhcPass 'Renamed) -> Text + mkCodeActionTitle exts se = + if OverloadedRecordDot `elem` exts + then title + else title <> " (needs extension: OverloadedRecordDot)" + where + title = "Convert `" <> printOutputable se <> "` to record dot syntax" + +mkWorkspaceEdit:: Uri -> RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit +mkWorkspaceEdit uri recSel exts pragma = + Just $ WorkspaceEdit + { _changes = + Just (Map.singleton uri (convertRecordSelectors recSel : maybeToList pragmaEdit)) + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + where pragmaEdit = + if OverloadedRecordDot `elem` exts + then Nothing + else Just $ insertNewPragma pragma OverloadedRecordDot + +collectRecSelsRule :: Recorder (WithPriority Log) -> Rules () +collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ + \CollectRecordSelectors nfp -> + useWithStale TypeCheck nfp >>= \case + -- `useWithStale` here allows us to be able to return codeActions even + -- if the file does not typecheck. The disadvantage being that we + -- sometimes will end up corrupting code. This is most obvious in that + -- used code actions will continue to be presented, and when applied + -- multiple times will almost always cause code corruption. + Nothing -> pure ([], Nothing) + Just (tmr, pm) -> do + let -- We need the file's extensions to check whether we need to add + -- the OverloadedRecordDot pragma + exts = getEnabledExtensions tmr + recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr) + -- We are creating a list as long as our rec selectors of unique int s + -- created by calling hashUnique on a Unique. The reason why we are + -- extracting the ints is because they don't need any work to serialize. + uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique) + logWith recorder Debug (LogCollectedRecordSelectors recSels) + let crsUniquesAndDetails = zip uniques recSels + -- We need the rangeMap to be able to filter by range later + rangeAndUnique = toRangeAndUnique <$> crsUniquesAndDetails + crsMap :: RangeMap (Int, HsExpr (GhcPass 'Renamed)) + crsMap = RangeMap.fromList' rangeAndUnique + pure ([], CRSR <$> Just crsMap <*> Just (IntMap.fromList crsUniquesAndDetails) <*> Just exts) + where getEnabledExtensions :: TcModuleResult -> [Extension] + getEnabledExtensions = getExtensions . tmrParsed + getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr] + getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = + collectRecordSelectors valBinds + rewriteRange :: PositionMapping -> RecordSelectorExpr + -> Maybe RecordSelectorExpr + rewriteRange pm recSel = + case toCurrentRange pm (location recSel) of + Just newLoc -> Just $ recSel{location = newLoc} + Nothing -> Nothing + toRangeAndUnique (uid, RecordSelectorExpr l (unLoc -> se) _) = (l, (uid, se)) + +convertRecordSelectors :: RecordSelectorExpr -> TextEdit +convertRecordSelectors RecordSelectorExpr{..} = + TextEdit location $ convertRecSel selectorExpr recordExpr + +-- |Converts a record selector expression into record dot syntax, currently we +-- are using printOutputable to do it. We are also letting GHC decide when to +-- parenthesize the record expression +convertRecSel :: LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> Text +convertRecSel se re = printOutputable (parenthesizeHsExpr appPrec re) <> "." + <> printOutputable se + +collectRecordSelectors :: GenericQ [RecordSelectorExpr] +-- It's important that we use everthingBut here, because if we used everything +-- we would get duplicates for every case that occurs inside a HsExpanded +-- expression. Please see the test MultilineExpanded.hs +collectRecordSelectors = everythingBut (<>) (([], False) `mkQ` getRecSels) + +-- |We want to return a list here, because on the occasion that we encounter a +-- HsExpanded expression, we want to return all the results from recursing on +-- one branch, which could be multiple matches. Again see MultilineExpanded.hs +getRecSels :: LHsExpr (GhcPass 'Renamed) -> ([RecordSelectorExpr], Bool) +-- When we stumble upon an occurrence of HsExpanded, we only want to follow one +-- branch. We do this here, by explicitly returning occurrences from traversing +-- the original branch, and returning True, which keeps syb from implicitly +-- continuing to traverse. +getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True) +#if __GLASGOW_HASKELL__ >= 903 +-- applied record selection: "selector record" or "selector (record)" or +-- "selector selector2.record2" +getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +-- Record selection where the field is being applied with the "$" operator: +-- "selector $ record" +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) + (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#else +getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) + (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#endif +getRecSels _ = ([], False) + +collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath + -> ExceptT PluginError m CollectRecordSelectorsResult +collectRecSelResult ideState = + runActionE "overloadedRecordDot.collectRecordSelectors" ideState + . useE CollectRecordSelectors + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( main ) where + +import Data.Either (rights) +import qualified Data.Text as T +import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot +import System.FilePath (()) +import Test.Hls + +main :: IO () +main = + defaultTestRunner test + +plugin :: PluginTestDescriptor OverloadedRecordDot.Log +plugin = mkPluginTestDescriptor OverloadedRecordDot.descriptor "overloaded-record-dot" + +test :: TestTree +test = testGroup "overloaded-record-dot" + (mkTest "Simple" "Simple" "name" 10 7 10 15 + <> mkTest "NoPragmaNeeded" "NoPragmaNeeded" "name" 11 7 11 15 + <> mkTest "NestedParens" "NestedParens" "name" 15 7 15 24 + <> mkTest "NestedDot" "NestedDot" "name" 17 7 17 22 + <> mkTest "NestedDollar" "NestedDollar" "name" 15 7 15 24 + <> mkTest "MultilineCase" "MultilineCase" "name" 10 7 12 15 + <> mkTest "Multiline" "Multiline" "name" 10 7 11 15 + <> mkTest "MultilineExpanded" "MultilineExpanded" "owner" 28 8 28 19) + +mkTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> [TestTree] +mkTest title fp selectorName x1 y1 x2 y2 = + [mkNoResolveTest (title <> " without resolve") fp selectorName x1 y1 x2 y2, + mkResolveTest (title <> " with resolve") fp selectorName x1 y1 x2 y2] + +mkNoResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree +mkNoResolveTest title fp selectorName x1 y1 x2 y2 = + goldenWithHaskellAndCaps def codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2 + executeCodeAction act + +mkResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree +mkResolveTest title fp selectorName x1 y1 x2 y2 = + goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + (act:_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 + executeCodeAction act + + +getExplicitFieldsActions + :: TextDocumentIdentifier + -> T.Text + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getExplicitFieldsActions doc selectorName x1 y1 x2 y2 = + findExplicitFieldsAction selectorName <$> getCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +getAndResolveExplicitFieldsActions + :: TextDocumentIdentifier + -> T.Text + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 = do + findExplicitFieldsAction selectorName <$> getAndResolveCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +findExplicitFieldsAction :: T.Text -> [a |? CodeAction] -> [CodeAction] +findExplicitFieldsAction selectorName = filter (isExplicitFieldsCodeAction selectorName) . rights . map toEither + +isExplicitFieldsCodeAction :: T.Text -> CodeAction -> Bool +isExplicitFieldsCodeAction selectorName CodeAction {_title} = + ("Convert `" <> selectorName <> "` to record dot syntax") `T.isPrefixOf` _title + +testDataDir :: FilePath +testDataDir = "plugins" "hls-overloaded-record-dot-plugin" "test" "testdata" diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs @@ -0,0 +1,12 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name + man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = (case True of + True -> man + False -> man).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs @@ -0,0 +1,13 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name $ case True of + True -> man + False -> man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +home2 :: Building +home2 = Building {address = "No. 6 Beach Ave.", owner = man} + +home3 :: Building +home3 = Building {address = "No. 12 Central Blvd.", owner = man} + +n:: Int +n = 3 + +test :: String +test = (case n of + 0 -> owner home + 1 -> home2.owner + 2 -> owner home3 + _ -> man).name + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +home2 :: Building +home2 = Building {address = "No. 6 Beach Ave.", owner = man} + +home3 :: Building +home3 = Building {address = "No. 12 Central Blvd.", owner = man} + +n:: Int +n = 3 + +test :: String +test = (case n of + 0 -> owner home + 1 -> owner home2 + 2 -> owner home3 + _ -> man).name + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = (owner home).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs @@ -0,0 +1,16 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name $ owner home diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = home.owner.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name home.owner diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = (owner home).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs @@ -0,0 +1,16 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name (owner home) diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs @@ -0,0 +1,11 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml b/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: []}} diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Provides code actions to add missing pragmas (whenever GHC suggests to) +module Ide.Plugin.Pragmas + ( suggestPragmaDescriptor + , completionDescriptor + , suggestDisableWarningDescriptor + -- For testing + , validPragmas + , AppearWhere(..) + ) where + +import Control.Lens hiding (List) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Data.Char (isAlphaNum) +import Data.List.Extra (nubOrdOn) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Development.IDE hiding (line) +import Development.IDE.Core.Compile (sourceParser, + sourceTypecheck) +import Development.IDE.Core.PluginUtils +import Development.IDE.GHC.Compat +import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) +import Development.IDE.Plugin.Completions.Logic (getCompletionPrefix) +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) +import qualified Development.IDE.Spans.Pragmas as Pragmas +import Ide.Plugin.Error +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Text.Fuzzy as Fuzzy + +-- --------------------------------------------------------------------- + +suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState +suggestPragmaDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to add missing LANGUAGE pragmas") + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider + , pluginPriority = defaultPluginPriority + 1000 + } + +completionDescriptor :: PluginId -> PluginDescriptor IdeState +completionDescriptor plId = (defaultPluginDescriptor plId "Provides completion of LANGAUGE pragmas") + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion + , pluginPriority = ghcideCompletionsPluginPriority + 1 + } + +suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState +suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to disable warnings") + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider + -- #3636 Suggestions to disable warnings should appear last. + , pluginPriority = 0 + } + +-- --------------------------------------------------------------------- +-- | Title and pragma +type PragmaEdit = (T.Text, Pragma) + +data Pragma = LangExt T.Text | OptGHC T.Text + deriving (Show, Eq, Ord) + +suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +suggestPragmaProvider = mkCodeActionProvider suggest + +suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning + +mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +mkCodeActionProvider mkSuggest state _plId + (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do + normalizedFilePath <- getNormalizedFilePathE uri + -- ghc session to get some dynflags even if module isn't parsed + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- + runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath + (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath + parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath + let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule + nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents + pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags + pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits + + + +-- | Add a Pragma to the given URI at the top of the file. +-- It is assumed that the pragma name is a valid pragma, +-- thus, not validated. +pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction) +pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) = + LSP.InR $ LSP.CodeAction title (Just LSP.CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing + where + render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" + render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" + pragmaInsertPosition = Position (fromIntegral nextPragmaLine) 0 + pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition + -- workaround the fact that for some reason lsp-test applies text + -- edits in reverse order than lsp (tried in both coc.nvim and vscode) + textEdits = + if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits + , let LSP.TextEdit{ _range, _newText } = insertTextEdit -> + [LSP.TextEdit _range (render p <> _newText), deleteTextEdit] + | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)] + + edit = + LSP.WorkspaceEdit + (Just $ M.singleton uri textEdits) + Nothing + Nothing + +suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] +suggest dflags diag = + suggestAddPragma dflags diag + +-- --------------------------------------------------------------------- + +suggestDisableWarning :: Diagnostic -> [PragmaEdit] +suggestDisableWarning Diagnostic {_code} + | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code + , w `notElem` warningBlacklist = + pure ("Disable \"" <> w <> "\" warnings", OptGHC w) + | otherwise = [] + +-- Don't suggest disabling type errors as a solution to all type errors +warningBlacklist :: [T.Text] +warningBlacklist = ["deferred-type-errors"] + +-- --------------------------------------------------------------------- + +-- | Offer to add a missing Language Pragma to the top of a file. +-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. +suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] +suggestAddPragma mDynflags Diagnostic {_message, _source} + | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message + where + genPragma target = + [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled] + disabled + | Just dynFlags <- mDynflags = + -- GHC does not export 'OnOff', so we have to view it as string + mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags) + | otherwise = + -- When the module failed to parse, we don't have access to its + -- dynFlags. In that case, simply don't disable any pragmas. + [] +suggestAddPragma _ _ = [] + +-- | Find all Pragmas are an infix of the search term. +findPragma :: T.Text -> [T.Text] +findPragma str = concatMap check possiblePragmas + where + check p = [p | T.isInfixOf p str] + + -- We exclude the Strict extension as it causes many false positives, see + -- the discussion at https://github.com/haskell/ghcide/pull/638 + -- + -- We don't include the No- variants, as GHC never suggests disabling an + -- extension in an error message. + possiblePragmas :: [T.Text] + possiblePragmas = + [ name + | FlagSpec{flagSpecName = T.pack -> name} <- xFlags + , "Strict" /= name + ] + +-- | All language pragmas, including the No- variants +allPragmas :: [T.Text] +allPragmas = + concat + [ [name, "No" <> name] + | FlagSpec{flagSpecName = T.pack -> name} <- xFlags + ] + <> + -- These pragmas are not part of xFlags as they are not reversable + -- by prepending "No". + [ -- Safe Haskell + "Unsafe" + , "Trustworthy" + , "Safe" + + -- Language Version Extensions + , "Haskell98" + , "Haskell2010" + , "GHC2021" + ] + +-- --------------------------------------------------------------------- +flags :: [T.Text] +flags = map T.pack $ flagsForCompletion False + +completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion +completion _ide _ complParams = do + let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument + position@(Position ln col) = complParams ^. L.position + contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + fmap LSP.InL $ case (contents, uriToFilePath' uri) of + (Just cnts, Just _path) -> + pure $ result $ getCompletionPrefix position cnts + where + result pfix + | "{-# language" `T.isPrefixOf` line + = map mkLanguagePragmaCompl $ + Fuzzy.simpleFilter word allPragmas + | "{-# options_ghc" `T.isPrefixOf` line + = let optionPrefix = getGhcOptionPrefix pfix + prefixLength = fromIntegral $ T.length optionPrefix + prefixRange = LSP.Range (Position ln (col - prefixLength)) position + in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter optionPrefix flags + | "{-#" `T.isPrefixOf` line + = [ mkPragmaCompl (a <> suffix) b c + | (a, b, c, w) <- validPragmas, w == NewLine + ] + | -- Do not suggest any pragmas under any of these conditions: + -- 1. Current line is an import + -- 2. There is a module name right before the current word. + -- Something like `Text.la` shouldn't suggest adding the + -- 'LANGUAGE' pragma. + -- 3. The user has not typed anything yet. + "import" `T.isPrefixOf` line || not (T.null module_) || T.null word + = [] + | otherwise + = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail + | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas + , case appearWhere of + -- Only suggest a pragma that needs its own line if the whole line + -- fuzzily matches the pragma + NewLine -> Fuzzy.test line matcher + -- Only suggest a pragma that appears in the middle of a line when + -- the current word is not the only thing in the line and the + -- current word fuzzily matches the pragma + CanInline -> line /= word && Fuzzy.test word matcher + ] + where + line = T.toLower $ fullLine pfix + module_ = prefixScope pfix + word = prefixText pfix + -- Not completely correct, may fail if more than one "{-#" exists. + -- We can ignore it since it rarely happens. + prefix + | "{-# " `T.isInfixOf` line = "" + | "{-#" `T.isInfixOf` line = " " + | otherwise = "{-# " + suffix + | " #-}" `T.isSuffixOf` line = "" + | "#-}" `T.isSuffixOf` line = " " + | "-}" `T.isSuffixOf` line = " #" + | "}" `T.isSuffixOf` line = " #-" + | otherwise = " #-}" + _ -> return [] + +----------------------------------------------------------------------- + +-- | Pragma where exist +data AppearWhere = + NewLine + -- ^Must be on a new line + | CanInline + -- ^Can appear in the line + deriving (Show, Eq) + +validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)] +validPragmas = + [ ("LANGUAGE ${1:extension}" , "LANGUAGE" , "{-# LANGUAGE #-}" , NewLine) + , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC" , "{-# OPTIONS_GHC #-}" , NewLine) + , ("INLINE ${1:function}" , "INLINE" , "{-# INLINE #-}" , NewLine) + , ("NOINLINE ${1:function}" , "NOINLINE" , "{-# NOINLINE #-}" , NewLine) + , ("INLINABLE ${1:function}" , "INLINABLE" , "{-# INLINABLE #-}" , NewLine) + , ("WARNING ${1:message}" , "WARNING" , "{-# WARNING #-}" , CanInline) + , ("DEPRECATED ${1:message}" , "DEPRECATED" , "{-# DEPRECATED #-}" , CanInline) + , ("ANN ${1:annotation}" , "ANN" , "{-# ANN #-}" , NewLine) + , ("RULES" , "RULES" , "{-# RULES #-}" , NewLine) + , ("SPECIALIZE ${1:function}" , "SPECIALIZE" , "{-# SPECIALIZE #-}" , NewLine) + , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}", NewLine) + , ("SPECIALISE ${1:function}" , "SPECIALISE" , "{-# SPECIALISE #-}" , NewLine) + , ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}", NewLine) + , ("MINIMAL ${1:functions}" , "MINIMAL" , "{-# MINIMAL #-}" , CanInline) + , ("UNPACK" , "UNPACK" , "{-# UNPACK #-}" , CanInline) + , ("NOUNPACK" , "NOUNPACK" , "{-# NOUNPACK #-}" , CanInline) + , ("COMPLETE ${1:function}" , "COMPLETE" , "{-# COMPLETE #-}" , NewLine) + , ("OVERLAPPING" , "OVERLAPPING" , "{-# OVERLAPPING #-}" , CanInline) + , ("OVERLAPPABLE" , "OVERLAPPABLE" , "{-# OVERLAPPABLE #-}" , CanInline) + , ("OVERLAPS" , "OVERLAPS" , "{-# OVERLAPS #-}" , CanInline) + , ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline) + ] + +mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem +mkPragmaCompl insertText label detail = + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing (Just detail) + Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem +mkLanguagePragmaCompl label = + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +mkGhcOptionCompl :: Range -> T.Text -> LSP.CompletionItem +mkGhcOptionCompl editRange completedFlag = + LSP.CompletionItem completedFlag Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing (Just insertCompleteFlag) Nothing Nothing Nothing Nothing Nothing + where + insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag + +-- The prefix extraction logic of getCompletionPrefix +-- doesn't consider '-' part of prefix which breaks completion +-- of flags like "-ddump-xyz". For OPTIONS_GHC completion we need the whole thing +-- to be considered completion prefix, but `prefixText posPrefixInfo` would return"xyz" in this case +getGhcOptionPrefix :: PosPrefixInfo -> T.Text +getGhcOptionPrefix PosPrefixInfo {cursorPos = Position _ col, fullLine}= + T.takeWhileEnd isGhcOptionChar beforePos + where + beforePos = T.take (fromIntegral col) fullLine + + -- Is this character contained in some GHC flag? Based on: + -- >>> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False + -- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz" + isGhcOptionChar :: Char -> Bool + isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String) diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Lens ((<&>), (^.)) +import Data.Aeson +import Data.Foldable +import qualified Data.Text as T +import Ide.Plugin.Pragmas +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +pragmasSuggestPlugin :: PluginTestDescriptor () +pragmasSuggestPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas" + +pragmasCompletionPlugin :: PluginTestDescriptor () +pragmasCompletionPlugin = mkPluginTestDescriptor' completionDescriptor "pragmas" + +pragmasDisableWarningPlugin :: PluginTestDescriptor () +pragmasDisableWarningPlugin = mkPluginTestDescriptor' suggestDisableWarningDescriptor "pragmas" + +tests :: TestTree +tests = + testGroup "pragmas" + [ codeActionTests + , codeActionTests' + , completionTests + , completionSnippetTests + , dontSuggestCompletionTests + ] + +codeActionTests :: TestTree +codeActionTests = + testGroup "code actions" + [ codeActionTestWithPragmasSuggest "Block comment then line comment doesn't split line" "BlockCommentThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block comment doesn't split line" "BlockCommentThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then multi-line block comment doesn't split line" "BlockCommentThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then line haddock splits line" "BlockCommentThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock splits line" "BlockCommentThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then multi-line block haddock splits line" "BlockCommentThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line comment doesn't split line" "PragmaThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block comment doesn't split line" "PragmaThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then multi-line block comment splits line" "PragmaThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line haddock splits line" "PragmaThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock splits line" "PragmaThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then multi-line block haddock splits line" "PragmaThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock single-line block comment splits line" "PragmaThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock single-line block comment splits line" "BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line haddock then newline line comment splits line" "PragmaThenLineHaddockNewlineLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "does not add pragma after OPTIONS_GHC pragma located after a declaration" "OptionsGhcAfterDecl" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds above module keyword on first line" "ModuleOnFirstLine" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after GHC_OPTIONS" "AfterGhcOptions" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds TypeApplications pragma" "TypeApplications" [("Add \"TypeApplications\"", "Contains TypeApplications code action")] + , codeActionTestWithPragmasSuggest "after shebang" "AfterShebang" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "append to existing pragmas" "AppendToExisting" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "before doc comments" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")] + , codeActionTestWithDisableWarning "before doc comments" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")] + , codeActionTestWithDisableWarning "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] + ] + +codeActionTestWithPragmasSuggest :: String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWithPragmasSuggest = codeActionTestWith pragmasSuggestPlugin + +codeActionTestWithDisableWarning :: String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWithDisableWarning = codeActionTestWith pragmasDisableWarningPlugin + +codeActionTestWith :: PluginTestDescriptor () -> String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWith descriptor testComment fp actions = + goldenWithPragmas descriptor testComment fp $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + mapM_ (\(action, contains) -> go action contains cas) actions + action <- case cas of + (a:_) -> pure a + [] -> liftIO $ assertFailure "Expected non-empty list of code actions" + executeCodeAction action + where + go action contains cas = liftIO $ action `elem` map (^. L.title) cas @? contains + +codeActionTests' :: TestTree +codeActionTests' = + testGroup "additional code actions" + [ goldenWithPragmas pragmasSuggestPlugin "no duplication" "NamedFieldPuns" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9)) + ca <- liftIO $ case cas of + [ca] -> pure ca + _ -> assertFailure $ "Expected one code action, but got: " <> show cas + liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action" + executeCodeAction ca + , goldenWithPragmas pragmasSuggestPlugin "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + liftIO $ "Disable \"deferred-type-errors\" warnings" `notElem` map (^. L.title) cas @? "Doesn't contain deferred-type-errors code action" + liftIO $ length cas == 0 @? "Expected no code actions, but got: " <> show cas + ] + +completionTests :: TestTree +completionTests = + testGroup "completions" + [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 31, 0, 4) + , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") (0, 4, 0, 32, 0, 4) + , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") (0, 4, 0, 33, 0, 4) + , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "-Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24) + , completionTest "completes ghc options pragma values with multiple dashes" "Completion.hs" "{-# OPTIONS_GHC -fmax-worker-ar #-}\n" "-fmax-worker-args" Nothing Nothing Nothing (0, 0, 0, 0, 0, 31) + , completionTest "completes multiple ghc options within single pragma" "Completion.hs" "{-# OPTIONS_GHC -ddump-simpl -ddump-spl #-}\n" "-ddump-splices" Nothing Nothing Nothing (0, 0, 0, 0, 0, 39) + , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24) + , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24) + , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) + , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing (0, 13, 0, 31, 0, 23) + , completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) + ] + +completionSnippetTests :: TestTree +completionSnippetTests = + testGroup "expand snippet to pragma" $ + validPragmas <&> + (\(insertText, label, detail, appearWhere) -> + let inputPrefix = + case appearWhere of + NewLine -> "" + CanInline -> "something " + input = inputPrefix <> (T.toLower $ T.init label) + in completionTest (T.unpack label) + "Completion.hs" input label (Just InsertTextFormat_Snippet) + (Just $ "{-# " <> insertText <> " #-}") (Just detail) + (0, 0, 0, 34, 0, fromIntegral $ T.length input)) + +dontSuggestCompletionTests :: TestTree +dontSuggestCompletionTests = + testGroup "do not suggest pragmas" $ + let replaceFuncBody newBody = Just $ mkEdit (8,6) (8,8) newBody + writeInEmptyLine txt = Just $ mkEdit (3,0) (3,0) txt + generalTests = [ provideNoCompletionsTest "in imports" "Completion.hs" (Just $ mkEdit (3,0) (3,0) "import WA") (Position 3 8) + , provideNoCompletionsTest "when no word has been typed" "Completion.hs" Nothing (Position 3 0) + , provideNoCompletionsTest "when expecting auto complete on modules" "Completion.hs" (Just $ mkEdit (8,6) (8,8) "Data.Maybe.WA") (Position 8 19) + ] + individualPragmaTests = validPragmas <&> \(_insertText,label,_detail,appearWhere) -> + let completionPrompt = T.toLower $ T.init label + promptLen = fromIntegral (T.length completionPrompt) + in case appearWhere of + CanInline -> + provideNoUndesiredCompletionsTest ("at new line: " <> T.unpack label) "Completion.hs" (Just label) (writeInEmptyLine completionPrompt) (Position 3 0) + NewLine -> + provideNoUndesiredCompletionsTest ("inline: " <> T.unpack label) "Completion.hs" (Just label) (replaceFuncBody completionPrompt) (Position 8 (6 + promptLen)) + in generalTests ++ individualPragmaTests + +mkEdit :: (UInt,UInt) -> (UInt,UInt) -> T.Text -> TextEdit +mkEdit (startLine, startCol) (endLine, endCol) newText = + TextEdit (Range (Position startLine startCol) (Position endLine endCol)) newText + +completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> (UInt, UInt, UInt, UInt, UInt, UInt) -> TestTree +completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail (delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol) = + testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do + doc <- openDoc fileName "haskell" + _ <- waitForDiagnostics + let te = TextEdit (Range (Position delFromLine delFromCol) (Position delToLine delToCol)) replacementText + _ <- applyEdit doc te + compls <- getCompletions doc (Position completeAtLine completeAtCol) + item <- getCompletionByLabel expectedLabel compls + liftIO $ do + item ^. L.label @?= expectedLabel + item ^. L.kind @?= Just CompletionItemKind_Keyword + item ^. L.insertTextFormat @?= expectedFormat + item ^. L.insertText @?= expectedInsertText + item ^. L.detail @?= detail + +provideNoCompletionsTest :: String -> FilePath -> Maybe TextEdit -> Position -> TestTree +provideNoCompletionsTest testComment fileName mTextEdit pos = + provideNoUndesiredCompletionsTest testComment fileName Nothing mTextEdit pos + +provideNoUndesiredCompletionsTest :: String -> FilePath -> Maybe T.Text -> Maybe TextEdit -> Position -> TestTree +provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit pos = + testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do + setConfigSection "haskell" disableGhcideCompletions + doc <- openDoc fileName "haskell" + _ <- waitForDiagnostics + mapM_ (applyEdit doc) mTextEdit + compls <- getCompletions doc pos + liftIO $ case mUndesiredLabel of + Nothing -> compls @?= [] + Just undesiredLabel -> do + case find (\c -> c ^. L.label == undesiredLabel) compls of + Just c -> assertFailure $ + "Did not expect a completion with label=" <> T.unpack undesiredLabel + <> ", got completion: "<> show c + Nothing -> pure () + +disableGhcideCompletions :: Value +disableGhcideCompletions = object [ "plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]] + +goldenWithPragmas :: PluginTestDescriptor () -> TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithPragmas descriptor title path = goldenWithHaskellDoc def descriptor title testDataDir path "expected" "hs" + +testDataDir :: FilePath +testDataDir = "plugins" "hls-pragmas-plugin" "test" "testdata" diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.expected.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE BangPatterns #-} + +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} + +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.expected.hs @@ -0,0 +1,21 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +test :: Int -> Integer +test x = x * 2 + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.hs @@ -0,0 +1,20 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +test :: Int -> Integer +test x = x * 2 + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module NeedsLanguagePragma where + +tupleSection = (1,) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NeedsLanguagePragma where + +tupleSection = (1,) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.expected.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.expected.hs @@ -0,0 +1,12 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +test :: Int -> Integer +test x = x * 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.hs b/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.hs @@ -0,0 +1,11 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +test :: Int -> Integer +test x = x * 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.expected.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE TupleSections #-} +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall #-} +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TupleSections #-} +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.hs @@ -0,0 +1,10 @@ +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE BangPatterns #-} +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.hs @@ -0,0 +1,11 @@ +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE TupleSections #-} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.hs b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs @@ -0,0 +1,22 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs @@ -0,0 +1,21 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.expected.hs @@ -0,0 +1,13 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE NamedFieldPuns #-} + +module AfterShebang where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebang.hs @@ -0,0 +1,12 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module AfterShebang where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs @@ -0,0 +1,13 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs @@ -0,0 +1,12 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs @@ -0,0 +1,18 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs @@ -0,0 +1,17 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs @@ -0,0 +1,12 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs @@ -0,0 +1,11 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs @@ -0,0 +1,16 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs @@ -0,0 +1,15 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE OverloadedStrings #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.expected.hs @@ -0,0 +1,12 @@ +-- | Doc before pragma +{-# OPTIONS_GHC -Wno-dodgy-imports #-} +{-# LANGUAGE NamedFieldPuns #-} +module AppendToExisting where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.hs b/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AppendToExisting.hs @@ -0,0 +1,11 @@ +-- | Doc before pragma +{-# OPTIONS_GHC -Wno-dodgy-imports #-} +module AppendToExisting where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.expected.hs @@ -0,0 +1,15 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# LANGUAGE NamedFieldPuns #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.hs b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocComment.hs @@ -0,0 +1,14 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.expected.hs @@ -0,0 +1,18 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.hs b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.hs @@ -0,0 +1,17 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.expected.hs @@ -0,0 +1,6 @@ +{- block comment -} -- line comment +{-# LANGUAGE TupleSections #-} + +module BlockCommentThenLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineComment.hs @@ -0,0 +1,5 @@ +{- block comment -} -- line comment + +module BlockCommentThenLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.expected.hs @@ -0,0 +1,7 @@ +{- block comment -} +{-# LANGUAGE TupleSections #-} +-- | line haddock + +module BlockCommentThenLineHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenLineHaddock.hs @@ -0,0 +1,5 @@ +{- block comment -} -- | line haddock + +module BlockCommentThenLineHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.expected.hs @@ -0,0 +1,10 @@ +{- block comment -} {- multi +line +block +comment +-} +{-# LANGUAGE TupleSections #-} + +module BlockCommentThenMultiLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockComment.hs @@ -0,0 +1,9 @@ +{- block comment -} {- multi +line +block +comment +-} + +module BlockCommentThenMultiLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.expected.hs @@ -0,0 +1,13 @@ +{- block comment -} +{-# LANGUAGE TupleSections #-} +{-| multi +line +block +haddock +-} + +module BlockCommentThenMultiLineBlockHaddock where +import Data.List (intercalate) +import System.IO (hFlush) + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenMultiLineBlockHaddock.hs @@ -0,0 +1,11 @@ +{- block comment -} {-| multi +line +block +haddock +-} + +module BlockCommentThenMultiLineBlockHaddock where +import Data.List (intercalate) +import System.IO (hFlush) + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.expected.hs @@ -0,0 +1,6 @@ +{- block comment -} {- single line block comment -} +{-# LANGUAGE TupleSections #-} + +module BlockCommentThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockComment.hs @@ -0,0 +1,5 @@ +{- block comment -} {- single line block comment -} + +module BlockCommentThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.expected.hs @@ -0,0 +1,7 @@ +{- block comment -} +{-# LANGUAGE TupleSections #-} +{-| single line block haddock -} + +module BlockCommentThenSingleLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddock.hs @@ -0,0 +1,5 @@ +{- block comment -} {-| single line block haddock -} + +module BlockCommentThenSingleLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs @@ -0,0 +1,7 @@ +{- block comment -} +{-# LANGUAGE TupleSections #-} +{-| single line block haddock -} {- single line block comment -} + +module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment.hs @@ -0,0 +1,5 @@ +{- block comment -} {-| single line block haddock -} {- single line block comment -} + +module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/Completion.hs b/plugins/hls-pragmas-plugin/test/testdata/Completion.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/Completion.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Maybe +import qualified Data.List + +main :: IO () +main = putStrLn "hello" + +foo :: Either a b -> Either a b +foo = id diff --git a/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.expected.hs @@ -0,0 +1,4 @@ +module DeferredTypeErrors where + +foo :: Int +foo = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.hs b/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/DeferredTypeErrors.hs @@ -0,0 +1,4 @@ +module DeferredTypeErrors where + +foo :: Int +foo = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.expected.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +main = putStrLn "hello" diff --git a/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.hs b/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/MissingSignatures.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -Wall #-} +main = putStrLn "hello" diff --git a/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Main where + +tupleSection = (1,) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs @@ -0,0 +1,3 @@ +module Main where + +tupleSection = (1,) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NamedFieldPuns #-} +module NamedFieldPuns where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.hs b/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/NamedFieldPuns.hs @@ -0,0 +1,9 @@ +module NamedFieldPuns where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a diff --git a/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module NeedsPragmas where + +import GHC.Generics + +main = putStrLn "hello" + +type Foo = Int + +instance Show Foo where + show x = undefined + +instance Show (Int,String) where + show = undefined + +data FFF a = FFF Int String a + deriving (Generic,Functor,Traversable) diff --git a/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.hs b/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/NeedsPragmas.hs @@ -0,0 +1,16 @@ +module NeedsPragmas where + +import GHC.Generics + +main = putStrLn "hello" + +type Foo = Int + +instance Show Foo where + show x = undefined + +instance Show (Int,String) where + show = undefined + +data FFF a = FFF Int String a + deriving (Generic,Functor,Traversable) diff --git a/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TupleSections #-} +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# OPTIONS_GHC addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.hs b/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/OptionsGhcAfterDecl.hs @@ -0,0 +1,10 @@ +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# OPTIONS_GHC addOne #-} +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaFollowedBySingleLineBlockHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaFollowedBySingleLineBlockHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaFollowedBySingleLineBlockHaddock.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} {-| haddock -} + +module PragmaFollowedByBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeApplications #-} -- line comment +{-# LANGUAGE TupleSections #-} + +module PragmaThenLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineComment.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} -- line comment + +module PragmaThenLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +-- | line haddock + +module PragmaThenLineHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddock.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} -- | line haddock + +module PragmaThenLineHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +-- | line haddock +-- line comment + +module PragmaThenLineHaddockNewlineLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenLineHaddockNewlineLineComment.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeApplications #-} -- | line haddock +-- line comment + +module PragmaThenLineHaddockNewlineLineComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{- multi +line +block +comment +-} + +module PragmaThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockComment.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeApplications #-} {- multi +line +block +comment +-} + +module PragmaThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-| multi +line +block +haddock +-} + +module PragmaThenMultiLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenMultiLineBlockHaddock.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeApplications #-} {-| multi +line +block +haddock +-} + +module PragmaThenMultiLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeApplications #-} {- single line block comment -} +{-# LANGUAGE TupleSections #-} + +module PragmaThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockComment.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} {- single line block comment -} + +module PragmaThenSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-| single line block haddock -} + +module PragmaThenSingleLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddock.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} {-| single line block haddock -} + +module PragmaThenSingleLineBlockHaddock where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-| single line block haddock -} {- single line block comment -} + +module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaThenSingleLineBlockHaddockSingleLineBlockComment.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} {-| single line block haddock -} {- single line block comment -} + +module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where + +a = (1,) diff --git a/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module TypeApplications where + +foo :: forall a. a -> a +foo = id @a diff --git a/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.hs b/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/TypeApplications.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module TypeApplications where + +foo :: forall a. a -> a +foo = id @a diff --git a/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.expected.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + + +module M where + +import Data.Functor diff --git a/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.hs b/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/UnusedImports.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} + + +module M where + +import Data.Functor diff --git a/plugins/hls-pragmas-plugin/test/testdata/hie.yaml b/plugins/hls-pragmas-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/hie.yaml @@ -0,0 +1,7 @@ +cradle: + direct: + arguments: + - "-XHaskell2010" + - "NeedsPragmas" + - "TypeApplications" + - "NamedFieldPuns" diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.QualifyImportedNames (descriptor) where + +import Control.Lens ((^.)) +import Control.Monad (foldM) +import Control.Monad.Trans.State.Strict (State) +import qualified Control.Monad.Trans.State.Strict as State +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Foldable (Foldable (foldl'), find) +import Data.List (sortOn) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Development.IDE (spanContainsRange) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), + GetHieAst (GetHieAst), + HieAstResult (HAR, refMap), + TcModuleResult (TcModuleResult, tmrParsed, tmrTypechecked), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Shake (IdeState) +import Development.IDE.GHC.Compat (ContextInfo (Use), + GenLocated (..), GhcPs, + GlobalRdrElt, GlobalRdrEnv, + HsModule (hsmodImports), + Identifier, + IdentifierDetails (IdentifierDetails, identInfo), + ImpDeclSpec (ImpDeclSpec, is_as, is_dloc, is_qual), + ImportSpec (ImpSpec), + LImportDecl, ModuleName, + Name, NameEnv, ParsedModule, + RefMap, Span, SrcSpan, + TcGblEnv (tcg_rdr_env), + emptyUFM, globalRdrEnvElts, + gre_imp, gre_name, locA, + lookupNameEnv, + moduleNameString, + nameOccName, occNameString, + pattern GRE, + pattern ParsedModule, + plusUFM_C, pm_parsed_source, + srcSpanEndCol, + srcSpanEndLine, + srcSpanStartCol, + srcSpanStartLine, unitUFM) +import Development.IDE.Types.Location (Position (Position), + Range (Range), Uri) +import Ide.Plugin.Error (PluginError (PluginRuleFailed), + getNormalizedFilePathE, + handleMaybe) +import Ide.Types (PluginDescriptor (pluginHandlers), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction), + SMethod (SMethod_TextDocumentCodeAction)) +import Language.LSP.Protocol.Types (CodeAction (CodeAction, _command, _data_, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title), + CodeActionKind (CodeActionKind_QuickFix), + CodeActionParams (CodeActionParams), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (InL, InR)) + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor pluginId = (defaultPluginDescriptor pluginId "Provides a code action to qualify imported names") { + pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider + ] +} + +findLImportDeclAt :: Range -> ParsedModule -> Maybe (LImportDecl GhcPs) +findLImportDeclAt range parsedModule + | ParsedModule {..} <- parsedModule + , L _ hsModule <- pm_parsed_source + , locatedImportDecls <- hsmodImports hsModule = + find (\ (L (locA -> srcSpan) _) -> fromMaybe False $ srcSpan `spanContainsRange` range) locatedImportDecls + +makeCodeActions :: Uri -> [TextEdit] -> [a |? CodeAction] +makeCodeActions uri textEdits = [InR CodeAction {..} | not (null textEdits)] + where _title = "Qualify imported names" + _kind = Just CodeActionKind_QuickFix + _command = Nothing + _edit = Just WorkspaceEdit {..} + _changes = Just $ Map.singleton uri textEdits + _documentChanges = Nothing + _diagnostics = Nothing + _isPreferred = Nothing + _disabled = Nothing + _data_ = Nothing + _changeAnnotations = Nothing + +data ImportedBy = ImportedBy { + importedByAlias :: !ModuleName, + importedBySrcSpan :: !SrcSpan +} + +isRangeWithinImportedBy :: Range -> ImportedBy -> Bool +isRangeWithinImportedBy range ImportedBy{importedBySrcSpan} = fromMaybe False $ spanContainsRange importedBySrcSpan range + +globalRdrEnvToNameToImportedByMap :: GlobalRdrEnv -> NameEnv [ImportedBy] +globalRdrEnvToNameToImportedByMap = + fmap DList.toList . foldl' (plusUFM_C (<>)) emptyUFM . map globalRdrEltToNameToImportedByMap . globalRdrEnvElts + where + globalRdrEltToNameToImportedByMap :: GlobalRdrElt -> NameEnv (DList ImportedBy) + globalRdrEltToNameToImportedByMap GRE {..} = + unitUFM gre_name $ DList.fromList $ mapMaybe importSpecToImportedBy gre_imp + + importSpecToImportedBy :: ImportSpec -> Maybe ImportedBy + importSpecToImportedBy (ImpSpec ImpDeclSpec {..} _) + | is_qual = Nothing + | otherwise = Just (ImportedBy is_as is_dloc) + +data IdentifierSpan = IdentifierSpan { + identifierSpanLine :: !Int, + identifierSpanStartCol :: !Int, + identifierSpanEndCol :: !Int +} deriving (Show, Eq) + +instance Ord IdentifierSpan where + compare (IdentifierSpan line1 startCol1 endCol1) (IdentifierSpan line2 startCol2 endCol2) = + (line1 `compare` line2) `thenCmp` (startCol1 `compare` startCol2) `thenCmp` (endCol1 `compare` endCol2) + +realSrcSpanToIdentifierSpan :: Span -> Maybe IdentifierSpan +realSrcSpanToIdentifierSpan realSrcSpan + | let startLine = srcSpanStartLine realSrcSpan - 1 + , let endLine = srcSpanEndLine realSrcSpan - 1 + , startLine == endLine + , let startCol = srcSpanStartCol realSrcSpan - 1 + , let endCol = srcSpanEndCol realSrcSpan - 1 = + Just $ IdentifierSpan startLine startCol endCol + | otherwise = Nothing + +identifierSpanToRange :: IdentifierSpan -> Range +identifierSpanToRange (IdentifierSpan line startCol endCol) = + Range (Position (fromIntegral line) (fromIntegral startCol)) (Position (fromIntegral line) (fromIntegral endCol)) + +data UsedIdentifier = UsedIdentifier { + usedIdentifierName :: !Name, + usedIdentifierSpan :: !IdentifierSpan +} + +refMapToUsedIdentifiers :: RefMap a -> [UsedIdentifier] +refMapToUsedIdentifiers = DList.toList . Map.foldlWithKey' folder DList.empty + where + folder acc identifier spanIdentifierDetailsPairs = + DList.fromList (mapMaybe (uncurry (getUsedIdentifier identifier)) spanIdentifierDetailsPairs) <> acc + + getUsedIdentifier :: Identifier -> Span -> IdentifierDetails a -> Maybe UsedIdentifier + getUsedIdentifier identifier span IdentifierDetails {..} + | Just identifierSpan <- realSrcSpanToIdentifierSpan span + , Right name <- identifier + , Use `elem` identInfo = Just $ UsedIdentifier name identifierSpan + | otherwise = Nothing + +updateColOffset :: Int -> Int -> Int -> Int +updateColOffset row lineOffset colOffset + | row == lineOffset = colOffset + | otherwise = 0 + +usedIdentifiersToTextEdits :: Range -> NameEnv [ImportedBy] -> Text -> [UsedIdentifier] -> [TextEdit] +usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers + | let sortedUsedIdentifiers = sortOn usedIdentifierSpan usedIdentifiers = + State.evalState (makeStateComputation sortedUsedIdentifiers) (Text.lines sourceText, 0, 0) + where + folder :: [TextEdit] -> UsedIdentifier -> State ([Text], Int, Int) [TextEdit] + folder prevTextEdits UsedIdentifier{usedIdentifierName, usedIdentifierSpan} + | Just importedBys <- lookupNameEnv nameToImportedByMap usedIdentifierName + , Just ImportedBy{importedByAlias} <- find (isRangeWithinImportedBy range) importedBys + , let IdentifierSpan row startCol _ = usedIdentifierSpan + , let identifierRange = identifierSpanToRange usedIdentifierSpan + , let aliasText = Text.pack $ moduleNameString importedByAlias + , let identifierText = Text.pack $ occNameString $ nameOccName usedIdentifierName + , let qualifiedIdentifierText = aliasText <> "." <> identifierText = do + (sourceTextLines, lineOffset, updateColOffset row lineOffset -> colOffset) <- State.get + let lines = List.drop (row - lineOffset) sourceTextLines + let (replacementText, remainingLines) = + if | line : remainingLines <- lines + , let lineStartingAtIdentifier = Text.drop (startCol - colOffset) line + , Just (c, _) <- Text.uncons lineStartingAtIdentifier + , let isParenthesized = c == '(' + , let isBackticked = c == '`' + , let replacementText = + if | isParenthesized -> "(" <> qualifiedIdentifierText <> ")" + | isBackticked -> "`" <> qualifiedIdentifierText <> "`" + | otherwise -> qualifiedIdentifierText -> + (replacementText, lineStartingAtIdentifier : remainingLines) + | otherwise -> (qualifiedIdentifierText, lines) + let textEdit = TextEdit identifierRange replacementText + State.put (remainingLines, row, startCol) + pure $ textEdit : prevTextEdits + | otherwise = pure prevTextEdits + + makeStateComputation :: [UsedIdentifier] -> State ([Text], Int, Int) [TextEdit] + makeStateComputation usedIdentifiers = foldM folder [] usedIdentifiers + +-- The overall idea: +-- 1. GlobalRdrEnv from typechecking phase contains info on what imported a +-- name. +-- 2. refMap from GetHieAst contains location of names and how they are used. +-- 3. For each used name in refMap check whether the name comes from an import +-- at the origin of the code action. +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId range _) = do + normalizedFilePath <- getNormalizedFilePathE (documentId ^. L.uri) + TcModuleResult { tmrParsed, tmrTypechecked } <- runActionE "QualifyImportedNames.TypeCheck" ideState $ useE TypeCheck normalizedFilePath + if isJust (findLImportDeclAt range tmrParsed) + then do + HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst normalizedFilePath) + (_, sourceTextM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath) + sourceText <- handleMaybe (PluginRuleFailed "GetFileContents") sourceTextM + let globalRdrEnv = tcg_rdr_env tmrTypechecked + nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv + usedIdentifiers = refMapToUsedIdentifiers refMap + textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers + pure $ InL (makeCodeActions (documentId ^. L.uri) textEdits) + else pure $ InL [] + diff --git a/plugins/hls-qualify-imported-names-plugin/test/Main.hs b/plugins/hls-qualify-imported-names-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/Main.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Data.Foldable (find) +import Data.Text (Text) +import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames +import System.FilePath (()) +import Test.Hls (CodeAction (CodeAction, _title), + Command, MonadIO (liftIO), + PluginTestDescriptor, + Position (Position), + Range (Range), Session, + TestName, TestTree, + TextDocumentIdentifier, + assertBool, assertFailure, + def, defaultTestRunner, + executeCodeAction, + getCodeActions, + goldenWithHaskellDoc, + mkPluginTestDescriptor', + openDoc, runSessionWithServer, + testCase, testGroup, + type (|?) (InR)) + +import Prelude + +-- 1's based +data Point = Point { + line :: !Int, + column :: !Int +} + +makePoint :: Int -> Int -> Point +makePoint line column + | line >= 1 && column >= 1 = Point line column + | otherwise = error "Line or column is less than 1." + +isEmpty :: Foldable f => f a -> Bool +isEmpty = null + +makeCodeActionNotFoundAtString :: Point -> String +makeCodeActionNotFoundAtString Point {..} = + "CodeAction not found at line: " <> show line <> ", column: " <> show column + +makeCodeActionFoundAtString :: Point -> String +makeCodeActionFoundAtString Point {..} = + "CodeAction found at line: " <> show line <> ", column: " <> show column + +main :: IO () +main = defaultTestRunner $ testGroup "Qualify Imported Names" + [ + testCase "No CodeAction when not at import" $ + runSessionWithServer def pluginDescriptor testDataDir $ do + let point = makePoint 1 1 + document <- openDoc "NoImport.hs" "haskell" + actions <- getCodeActions document $ pointToRange point + liftIO $ assertBool (makeCodeActionFoundAtString point) (isEmpty actions) + , testCase "No CodeAction when import is qualified" $ + runSessionWithServer def pluginDescriptor testDataDir $ do + let point = makePoint 3 1 + document <- openDoc "QualifiedImport.hs" "haskell" + actions <- getCodeActions document $ pointToRange point + liftIO $ assertBool (makeCodeActionFoundAtString point) (isEmpty actions) + , codeActionGoldenTest + "CodeAction qualifies names with alias if imported module is aliased" + "AliasedImport" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies names with module name if imported module is not aliased" + "UnaliasedImport" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies only names in import's explicit non-hiding list" + "ExplicitImport" + (makePoint 4 1) + , codeActionGoldenTest + "CodeAction qualifies only names outside of import's explicit hiding list" + "ExplicitHidingImport" + (makePoint 4 1) + , codeActionGoldenTest + "CodeAction can qualify names not defined in modules they are imported from" + "Reexported" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction can qualify explicitly imported Prelude" + "ExplicitPrelude" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies only imported names" + "OnlyImportedNames" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies parenthesized operators properly" + "Parenthesized" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies backticked operators properly" + "Backticked" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction qualifies parenthesized and backticked operators on the same line properly" + "SameLine" + (makePoint 3 1) + , codeActionGoldenTest + "CodeAction doesn't qualify already qualified names" + "NoDoubleQualify" + (makePoint 3 1) + ] + +codeActionGoldenTest :: TestName -> FilePath -> Point -> TestTree +codeActionGoldenTest testCaseName goldenFilename point = + goldenWithQualifyImportedNames testCaseName goldenFilename $ \document -> do + actions <- getCodeActions document $ pointToRange point + case find ((== Just "Qualify imported names") . getCodeActionTitle) actions of + Just (InR codeAction) -> executeCodeAction codeAction + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +testDataDir :: String +testDataDir = "plugins" "hls-qualify-imported-names-plugin" "test" "data" + +pluginDescriptor :: PluginTestDescriptor () +pluginDescriptor = mkPluginTestDescriptor' QualifyImportedNames.descriptor "qualifyImportedNames" + +getCodeActionTitle :: (Command |? CodeAction) -> Maybe Text +getCodeActionTitle commandOrCodeAction + | InR CodeAction {_title} <- commandOrCodeAction = Just _title + | otherwise = Nothing + +goldenWithQualifyImportedNames :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithQualifyImportedNames testName path = + goldenWithHaskellDoc def pluginDescriptor testName testDataDir path "expected" "hs" + +pointToRange :: Point -> Range +pointToRange Point {..} + | line <- fromIntegral $ subtract 1 line + , column <- fromIntegral $ subtract 1 column = + Range (Position line column) (Position line $ column + 1) + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/A.hs b/plugins/hls-qualify-imported-names-plugin/test/data/A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/A.hs @@ -0,0 +1,12 @@ +module A (module B, a, b, op) where + +import B + +a :: Int -> Int +a = id + +b :: String -> String +b = id + +op :: Int -> Int -> Int +op = (+) diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.expected.hs @@ -0,0 +1,6 @@ +module AliasedImport where + +import A as B + +thing = B.a + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/AliasedImport.hs @@ -0,0 +1,6 @@ +module AliasedImport where + +import A as B + +thing = a + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/B.hs b/plugins/hls-qualify-imported-names-plugin/test/data/B.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/B.hs @@ -0,0 +1,7 @@ +module B where + +c :: Int +c = 3 + +d :: String +d = "d" diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.expected.hs @@ -0,0 +1,10 @@ +module Backticked where + +import Prelude + +f a b = a `Prelude.elem` b + +g a b = + let h = f a b + in a `Prelude.elem` b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Backticked.hs @@ -0,0 +1,10 @@ +module Backticked where + +import Prelude + +f a b = a `elem` b + +g a b = + let h = f a b + in a `elem` b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.expected.hs @@ -0,0 +1,8 @@ +module ExplicitHidingImport where + +import A +import A hiding (b) + +thing1 = A.a +thing2 = b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitHidingImport.hs @@ -0,0 +1,8 @@ +module ExplicitHidingImport where + +import A +import A hiding (b) + +thing1 = a +thing2 = b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.expected.hs @@ -0,0 +1,8 @@ +module ExplicitImport where + +import A (a) +import A (b) + +thing1 = a +thing2 = A.b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitImport.hs @@ -0,0 +1,8 @@ +module ExplicitImport where + +import A (a) +import A (b) + +thing1 = a +thing2 = b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.expected.hs @@ -0,0 +1,10 @@ +module ExplicitPrelude where + +import Prelude + +f :: Prelude.String -> Prelude.Int -> Prelude.Maybe Prelude.Bool +f a b = Prelude.Just Prelude.False + +class Prelude.Functor f => MyClass f where + method :: f Prelude.Int + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.hs b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/ExplicitPrelude.hs @@ -0,0 +1,10 @@ +module ExplicitPrelude where + +import Prelude + +f :: String -> Int -> Maybe Bool +f a b = Just False + +class Functor f => MyClass f where + method :: f Int + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.expected.hs @@ -0,0 +1,7 @@ +module NoDoubleQualify where + +import A as AAA + +thing = AAA.a +thing2 = (AAA.op) +thing3 = 1 `AAA.op` 2 diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.hs b/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/NoDoubleQualify.hs @@ -0,0 +1,7 @@ +module NoDoubleQualify where + +import A as AAA + +thing = AAA.a +thing2 = (AAA.op) +thing3 = 1 `AAA.op` 2 diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/NoImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/NoImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/NoImport.hs @@ -0,0 +1,4 @@ +module NoImport where + +f = 3 + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.expected.hs @@ -0,0 +1,16 @@ +module OnlyImportedNames where + +import A + +thing1 a = a + +thing2 b = b + +thing3 = f1 A.a A.c + +thing4 = f2 A.b A.d + +f1 a = a + +f2 c b = let { d = "k"; e = A.a } in c d ++ c b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/OnlyImportedNames.hs @@ -0,0 +1,16 @@ +module OnlyImportedNames where + +import A + +thing1 a = a + +thing2 b = b + +thing3 = f1 a c + +thing4 = f2 b d + +f1 a = a + +f2 c b = let { d = "k"; e = a } in c d ++ c b + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.expected.hs @@ -0,0 +1,6 @@ +module Parenthesized where + +import Prelude + +thing :: [Prelude.Int] -> [Prelude.Int] -> [Prelude.Int] +thing = (Prelude.<>) diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Parenthesized.hs @@ -0,0 +1,6 @@ +module Parenthesized where + +import Prelude + +thing :: [Int] -> [Int] -> [Int] +thing = (<>) diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/QualifiedImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/QualifiedImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/QualifiedImport.hs @@ -0,0 +1,4 @@ +module QualifiedImport where + +import qualified A + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.expected.hs @@ -0,0 +1,6 @@ +module Reexported where + +import A + +thing = A.c + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.hs b/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/Reexported.hs @@ -0,0 +1,6 @@ +module Reexported where + +import A + +thing = c + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.expected.hs @@ -0,0 +1,5 @@ +module SameLine where + +import A + +thing = ((A.a) . (A.a) . (A.a)) (1 `A.op` 2 `A.op` 3 `A.op` 4) diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.hs b/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/SameLine.hs @@ -0,0 +1,5 @@ +module SameLine where + +import A + +thing = ((a) . (a) . (a)) (1 `op` 2 `op` 3 `op` 4) diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.expected.hs b/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.expected.hs @@ -0,0 +1,6 @@ +module UnaliasedImport where + +import A + +thing = A.a + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.hs b/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/UnaliasedImport.hs @@ -0,0 +1,6 @@ +module UnaliasedImport where + +import A + +thing = a + diff --git a/plugins/hls-qualify-imported-names-plugin/test/data/hie.yaml b/plugins/hls-qualify-imported-names-plugin/test/data/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-qualify-imported-names-plugin/test/data/hie.yaml @@ -0,0 +1,17 @@ +cradle: + direct: + arguments: + - A.hs + - B.hs + - QualifiedImport.hs + - NoImport.hs + - AliasedImport.hs + - UnaliasedImport.hs + - ExplicitImport.hs + - ExplicitHidingImport.hs + - Reexported.hs + - ExplicitPrelude.hs + - OnlyImportedNames.hs + - Parenthesized.hs + - Backticked.hs + diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -0,0 +1,17 @@ +-- | This module contains compatibility constructs to write type signatures across +-- multiple ghc-exactprint versions, accepting that anything more ambitious is +-- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint +module Development.IDE.GHC.Compat.ExactPrint + ( ExactPrint + , exactPrint + , makeDeltaAst + , Retrie.Annotated, pattern Annotated, astA, annsA + ) where + +import Development.IDE.GHC.Compat.Parser +import Language.Haskell.GHC.ExactPrint as Retrie +import qualified Retrie.ExactPrint as Retrie + + +pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast +pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.GHC.Dump(showAstDataHtml) where +import qualified Data.ByteString as B +import Data.Data hiding (Fixity) +import Development.IDE.GHC.Compat hiding (LocatedA, + NameAnn) +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Util +import Generics.SYB (ext1Q, ext2Q, extQ) +import GHC.Hs hiding (AnnLet) +import GHC.Hs.Dump +import GHC.Plugins hiding (AnnLet) +import Prelude hiding ((<>)) + +-- | Show a GHC syntax tree in HTML. +showAstDataHtml :: (Data a, ExactPrint a) => a -> SDoc +showAstDataHtml a0 = html $ + header $$ + body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat + [ + li (pre $ text (exactPrint a0)), + li (showAstDataHtml' a0), + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) + ]) + where + tag = tag' [] + tag' attrs t cont = + angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs]) + <> cont + <> angleBrackets (char '/' <> text t) + ul = tag' [("class", text (show @String "nested"))] "ul" + li = tag "li" + caret x = tag' [("class", text "caret")] "span" "" <+> x + nested foo cts +#if !MIN_VERSION_ghc(9,3,0) + | cts == empty = foo +#endif + | otherwise = foo $$ (caret $ ul cts) + body cts = tag "body" $ cts $$ tag "script" (text js) + header = tag "head" $ tag "style" $ text css + html = tag "html" + pre = tag "pre" + showAstDataHtml' :: Data a => a -> SDoc + showAstDataHtml' = + generic + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan + `extQ` annotation + `extQ` annotationModule + `extQ` annotationAddEpAnn + `extQ` annotationGrhsAnn + `extQ` annotationEpAnnHsCase + `extQ` annotationEpAnnHsLet + `extQ` annotationAnnList + `extQ` annotationEpAnnImportDecl + `extQ` annotationAnnParen + `extQ` annotationTrailingAnn + `extQ` annotationEpaLocation + `extQ` addEpAnn + `extQ` lit `extQ` litr `extQ` litt + `extQ` sourceText + `extQ` deltaPos + `extQ` epaAnchor + `extQ` anchorOp + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var + `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + `extQ` srcSpanAnnA + `extQ` srcSpanAnnL + `extQ` srcSpanAnnP + `extQ` srcSpanAnnC + `extQ` srcSpanAnnN + + where generic :: Data a => a -> SDoc + generic t = nested (text $ showConstr (toConstr t)) + (vcat (gmapQ (li . showAstDataHtml') t)) + + string :: String -> SDoc + string = text . normalize_newlines . show + + fastString :: FastString -> SDoc + fastString s = braces $ + text "FastString:" + <+> text (normalize_newlines . show $ s) + + bytestring :: B.ByteString -> SDoc + bytestring = text . normalize_newlines . show + + list [] = brackets empty + list [x] = "[]" $$ showAstDataHtml' x + list xs = nested "[]" (vcat $ map (li . showAstDataHtml') xs) + + -- Eliminate word-size dependence + lit :: HsLit GhcPs -> SDoc + lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + lit l = generic l + + litr :: HsLit GhcRn -> SDoc + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> SDoc + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + + numericLit :: String -> Integer -> SourceText -> SDoc + numericLit tag x s = braces $ hsep [ text tag + , generic x + , generic s ] + + sourceText :: SourceText -> SDoc + sourceText NoSourceText = text "NoSourceText" +#if MIN_VERSION_ghc(9,7,0) + sourceText (SourceText src) = text "SourceText" <+> ftext src +#else + sourceText (SourceText src) = text "SourceText" <+> text src +#endif + + epaAnchor :: EpaLocation -> SDoc +#if MIN_VERSION_ghc(9,5,0) + epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r +#else + epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r +#endif + epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs + + anchorOp :: AnchorOperation -> SDoc + anchorOp UnchangedAnchor = "UnchangedAnchor" + anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp + + deltaPos :: DeltaPos -> SDoc + deltaPos (SameLine c) = text "SameLine" <+> ppr c + deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c + + name :: Name -> SDoc + name nm = braces $ text "Name:" <+> ppr nm + + occName n = braces $ + text "OccName:" + <+> text (occNameString n) + + moduleName :: ModuleName -> SDoc + moduleName m = braces $ text "ModuleName:" <+> ppr m + + srcSpan :: SrcSpan -> SDoc + srcSpan ss = char ' ' <> + hang (ppr ss) 1 + -- TODO: show annotations here + (text "") + + realSrcSpan :: RealSrcSpan -> SDoc + realSrcSpan ss = braces $ char ' ' <> + hang (ppr ss) 1 + -- TODO: show annotations here + (text "") + + addEpAnn :: AddEpAnn -> SDoc + addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s + + var :: Var -> SDoc + var v = braces $ text "Var:" <+> ppr v + + dataCon :: DataCon -> SDoc + dataCon c = braces $ text "DataCon:" <+> ppr c + + bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc + bagRdrName bg = braces $ + text "Bag(LocatedA (HsBind GhcPs)):" + $$ (list . bagToList $ bg) + + bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc + bagName bg = braces $ + text "Bag(LocatedA (HsBind Name)):" + $$ (list . bagToList $ bg) + + bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc + bagVar bg = braces $ + text "Bag(LocatedA (HsBind Var)):" + $$ (list . bagToList $ bg) + + nameSet ns = braces $ + text "NameSet:" + $$ (list . nameSetElemsStable $ ns) + + fixity :: Fixity -> SDoc + fixity fx = braces $ + text "Fixity:" + <+> ppr fx + + located :: (Data a, Data b) => GenLocated a b -> SDoc + located (L ss a) + = nested "L" (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) + + -- ------------------------- + + annotation :: EpAnn [AddEpAnn] -> SDoc + annotation = annotation' (text "EpAnn [AddEpAnn]") + + annotationModule :: EpAnn AnnsModule -> SDoc + annotationModule = annotation' (text "EpAnn AnnsModule") + + annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc + annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") + + annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") + + annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc + annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") + +#if MIN_VERSION_ghc(9,4,0) + annotationEpAnnHsLet :: EpAnn NoEpAnns -> SDoc + annotationEpAnnHsLet = annotation' (text "EpAnn NoEpAnns") +#else + annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc + annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") +#endif + + annotationAnnList :: EpAnn AnnList -> SDoc + annotationAnnList = annotation' (text "EpAnn AnnList") + + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") + + annotationAnnParen :: EpAnn AnnParen -> SDoc + annotationAnnParen = annotation' (text "EpAnn AnnParen") + + annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc + annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") + + annotationEpaLocation :: EpAnn EpaLocation -> SDoc + annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + + annotation' :: forall a. Data a => SDoc -> EpAnn a -> SDoc + annotation' _tag anns = nested (text $ showConstr (toConstr anns)) + (vcat (map li $ gmapQ showAstDataHtml' anns)) + + -- ------------------------- + + srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. Data a + => SDoc -> SrcSpanAnn' a -> SDoc + locatedAnn'' tag ss = + case cast ss of + Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> + nested "SrcSpanAnn" ( + li(showAstDataHtml' ann) + $$ li(srcSpan s)) + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> text (showConstr (toConstr ss)) + + +normalize_newlines :: String -> String +normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs +normalize_newlines (x:xs) = x:normalize_newlines xs +normalize_newlines [] = [] + +css :: String +css = unlines + [ "body {background-color: black; color: white ;}" + , "/* Remove default bullets */" + , "ul, #myUL {" + , " list-style-type: none;" + , "}" + , "/* Remove margins and padding from the parent ul */" + , "#myUL {" + , " margin: 0; " + , " padding: 0; " + , "} " + , "/* Style the caret/arrow */ " + , ".caret { " + , " cursor: pointer; " + , " user-select: none; /* Prevent text selection */" + , "} " + , "/* Create the caret/arrow with a unicode, and style it */" + , ".caret::before { " + , " content: \"\\25B6 \"; " + , " color: white; " + , " display: inline-block; " + , " margin-right: 6px; " + , "} " + , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */" + , ".caret-down::before { " + , " transform: rotate(90deg); " + , "} " + , "/* Hide the nested list */ " + , ".nested { " + , " display: none; " + , "} " + , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */" + , ".active { " + , " display: block;}" + ] + +js :: String +js = unlines + [ "var toggler = document.getElementsByClassName(\"caret\");" + , "var i;" + , "for (i = 0; i < toggler.length; i++) {" + , " toggler[i].addEventListener(\"click\", function() {" + , " this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");" + , " this.classList.toggle(\"caret-down\");" + , " }); }" + ] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -0,0 +1,741 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module hosts various abstractions and utility functions to work with ghc-exactprint. +module Development.IDE.GHC.ExactPrint + ( Graft(..), + graftDecls, + graftDeclsWithM, + annotate, + annotateDecl, + hoistGraft, + graftWithM, + graftExprWithM, + genericGraftWithSmallestM, + genericGraftWithLargestM, + graftSmallestDeclsWithM, + transform, + transformM, + ExactPrint(..), + modifySmallestDeclWithM, + modifyMgMatchesT, + modifyMgMatchesT', + modifySigWithM, + genAnchor1, + setPrecedingLines, + addParens, + addParensToCtxt, + modifyAnns, + removeComma, + -- * Helper function + eqSrcSpan, + eqSrcSpanA, + epl, + epAnn, + removeTrailingComma, + annotateParsedSource, + getAnnotatedParsedSourceRule, + GetAnnotatedParsedSource(..), + ASTElement (..), + ExceptStringT (..), + TransformT, + Log(..), + ) +where + +import Control.Applicative (Alternative) +import Control.Arrow ((***)) +import Control.DeepSeq +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Zip +import Data.Bifunctor +import Data.Bool (bool) +import Data.Default (Default) +import qualified Data.DList as DL +import Data.Either.Extra (mapLeft) +import Data.Functor.Classes +import Data.Functor.Contravariant +import Data.Monoid (All (All), getAll) +import qualified Data.Text as T +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (parseImport, + parsePattern, + parseType) +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.Graph (RuleResult, Rules) +import Development.IDE.Graph.Classes +import Generics.SYB +import Generics.SYB.GHC +import qualified GHC.Generics as GHC +import Ide.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) +import Ide.PluginUtils +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.LSP.Protocol.Types +import Retrie.ExactPrint hiding (parseDecl, + parseExpr, + parsePattern, + parseType) +#if MIN_VERSION_ghc(9,9,0) +import GHC.Plugins (showSDoc) +import GHC.Utils.Outputable (Outputable (ppr)) +#else +import GHC (EpAnn (..), + NameAdornment (NameParens), + NameAnn (..), + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + TrailingAnn (AddCommaAnn), + emptyComments, + spanAsAnchor) +import GHC.Parser.Annotation (AnnContext (..), + EpaLocation (EpaDelta), + deltaPos) +#endif + +import Control.Lens (_last, (&)) +import Control.Lens.Operators ((%~)) +import Data.List (partition) +import GHC (Anchor (..), + AnchorOperation, + DeltaPos (..), + SrcSpanAnnN, + realSrcSpan) +import GHC.Types.SrcLoc (generatedSrcSpan) + +setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a +setPrecedingLines ast n c = setEntryDP ast (deltaPos n c) +------------------------------------------------------------------------------ + +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + +instance Show (Annotated ParsedSource) where + show _ = "" + +instance NFData (Annotated ParsedSource) where + rnf = rwhnf + +data GetAnnotatedParsedSource = GetAnnotatedParsedSource + deriving (Eq, Show, Typeable, GHC.Generic) + +instance Hashable GetAnnotatedParsedSource +instance NFData GetAnnotatedParsedSource +type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource + +-- | Get the latest version of the annotated parse source with comments. +getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () +getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do + pm <- use GetParsedModuleWithComments nfp + return ([], fmap annotateParsedSource pm) + +annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0 + +------------------------------------------------------------------------------ + +{- | A transformation for grafting source trees together. Use the semigroup + instance to combine 'Graft's, and run them via 'transform'. +-} +newtype Graft m a = Graft + { runGraft :: DynFlags -> a -> TransformT m a + } + +hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a +hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) + +newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} + deriving newtype + ( MonadTrans + , Monad + , Functor + , Applicative + , Alternative + , Foldable + , Contravariant + , MonadIO + , Eq1 + , Ord1 + , Show1 + , Read1 + , MonadZip + , MonadPlus + , Eq + , Ord + , Show + , Read + ) + +instance Monad m => Fail.MonadFail (ExceptStringT m) where + fail = ExceptStringT . ExceptT . pure . Left + +instance Monad m => Semigroup (Graft m a) where + Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags + +instance Monad m => Monoid (Graft m a) where + mempty = Graft $ const pure + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transform :: + DynFlags -> + ClientCapabilities -> + VersionedTextDocumentIdentifier -> + Graft (Either String) ParsedSource -> + Annotated ParsedSource -> + Either String WorkspaceEdit +transform dflags ccs verTxtDocId f a = do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transformM :: + Monad m => + DynFlags -> + ClientCapabilities -> + VersionedTextDocumentIdentifier -> + Graft (ExceptStringT m) ParsedSource -> + Annotated ParsedSource -> + m (Either String WorkspaceEdit) +transformM dflags ccs verTextDocId f a = runExceptT $ + runExceptString $ do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (verTextDocId, T.pack src) (T.pack res) IncludeDeletions + + +-- | Returns whether or not this node requires its immediate children to have +-- be parenthesized and have a leading space. +-- +-- A more natural type for this function would be to return @(Bool, Bool)@, but +-- we use 'All' instead for its monoid instance. +needsParensSpace :: + HsExpr GhcPs -> + -- | (Needs parens, needs space) + (All, All) +needsParensSpace HsLam{} = (All False, All False) +needsParensSpace HsLamCase{} = (All False, All True) +needsParensSpace HsApp{} = mempty +needsParensSpace HsAppType{} = mempty +needsParensSpace OpApp{} = mempty +needsParensSpace HsPar{} = (All False, All False) +needsParensSpace SectionL{} = (All False, All False) +needsParensSpace SectionR{} = (All False, All False) +needsParensSpace ExplicitTuple{} = (All False, All False) +needsParensSpace ExplicitSum{} = (All False, All False) +needsParensSpace HsCase{} = (All False, All True) +needsParensSpace HsIf{} = (All False, All False) +needsParensSpace HsMultiIf{} = (All False, All False) +needsParensSpace HsLet{} = (All False, All True) +needsParensSpace HsDo{} = (All False, All False) +needsParensSpace ExplicitList{} = (All False, All False) +needsParensSpace RecordCon{} = (All False, All True) +needsParensSpace RecordUpd{} = mempty +needsParensSpace _ = mempty + + +------------------------------------------------------------------------------ + +{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the + given @Located ast@. The node at that position must already be a @Located + ast@, or this is a no-op. +-} +graft' :: + forall ast a l. + (Data a, ASTElement l ast) => + -- | Do we need to insert a space before this grafting? In do blocks, the + -- answer is no, or we will break layout. But in function applications, + -- the answer is yes, or the function call won't get its argument. Yikes! + -- + -- More often the answer is yes, so when in doubt, use that. + Bool -> + SrcSpan -> + LocatedAn l ast -> + Graft (Either String) a +graft' needs_space dst val = Graft $ \dflags a -> do + val' <- annotate dflags needs_space val + pure $ + everywhere' + ( mkT $ + \case + (L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> val' + l -> l + ) + a + + +-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts +-- parentheses if they're necessary. +graftExpr :: + forall a. + (Data a) => + SrcSpan -> + LHsExpr GhcPs -> + Graft (Either String) a +graftExpr dst val = Graft $ \dflags a -> do + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a + + runGraft + (graft' needs_space dst $ mk_parens val) + dflags + a + +getNeedsSpaceAndParenthesize :: + (ASTElement l ast, Data a) => + SrcSpan -> + a -> + (Bool, LocatedAn l ast -> LocatedAn l ast) +getNeedsSpaceAndParenthesize dst a = + -- Traverse the tree, looking for our replacement node. But keep track of + -- the context (parent HsExpr constructor) we're in while we do it. This + -- lets us determine whether or not we need parentheses. + let (needs_parens, needs_space) = + everythingWithContext (Nothing, Nothing) (<>) + ( mkQ (mempty, ) $ \x s -> case x of + (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst -> + (s, s) + L _ x' -> (mempty, Just *** Just $ needsParensSpace x') + ) a + in ( maybe True getAll needs_space + , bool id maybeParensAST $ maybe False getAll needs_parens + ) + + +------------------------------------------------------------------------------ + +graftExprWithM :: + forall m a. + (Fail.MonadFail m, Data a) => + SrcSpan -> + (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + Graft m a +graftExprWithM dst trans = Graft $ \dflags a -> do + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a + + everywhereM' + ( mkM $ + \case + val@(L src _ :: LHsExpr GhcPs) + | locA src `eqSrcSpan` dst -> do + mval <- trans val + case mval of + Just val' -> do + val'' <- + hoistTransform (either Fail.fail pure) + (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + pure val'' + Nothing -> pure val + l -> pure l + ) + a + +graftWithM :: + forall ast m a l. + (Fail.MonadFail m, Data a, ASTElement l ast) => + SrcSpan -> + (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) -> + Graft m a +graftWithM dst trans = Graft $ \dflags a -> do + everywhereM' + ( mkM $ + \case + val@(L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> do + mval <- trans val + case mval of + Just val' -> do + val'' <- + hoistTransform (either Fail.fail pure) $ + annotate dflags False $ maybeParensAST val' + pure val'' + Nothing -> pure val + l -> pure l + ) + a + +-- | Run the given transformation only on the smallest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithSmallestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the smallest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> ast -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> + smallestM (genericIsSubspan proxy dst) (trans dflags) + +-- | Run the given transformation only on the largest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithLargestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the largest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> ast -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> + largestM (genericIsSubspan proxy dst) (trans dflags) + + +graftDecls :: + forall a. + (HasDecls a) => + SrcSpan -> + [LHsDecl GhcPs] -> + Graft (Either String) a +graftDecls dst decs0 = Graft $ \dflags a -> do + decs <- forM decs0 $ \decl -> do + annotateDecl dflags decl + let go [] = DL.empty + go (L src e : rest) + | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest + | otherwise = DL.singleton (L src e) <> go rest + modifyDeclsT (pure . DL.toList . go) a + + +-- | Replace the smallest declaration whose SrcSpan satisfies the given condition with a new +-- list of declarations. +-- +-- For example, if you would like to move a where-clause-defined variable to the same +-- level as its parent HsDecl, you could use this function. +-- +-- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. If +-- not declaration matched, then `Nothing` is returned. +modifySmallestDeclWithM :: + forall a m r. + (HasDecls a, Monad m) => + (SrcSpan -> m Bool) -> + (LHsDecl GhcPs -> TransformT m ([LHsDecl GhcPs], r)) -> + a -> + TransformT m (a, Maybe r) +modifySmallestDeclWithM validSpan f a = do + let modifyMatchingDecl [] = pure (DL.empty, Nothing) + modifyMatchingDecl (ldecl@(L src _) : rest) = + TransformT (lift $ validSpan $ locA src) >>= \case + True -> do + (decs', r) <- f ldecl + pure (DL.fromList decs' <> DL.fromList rest, Just r) + False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest + modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a + +generatedAnchor :: AnchorOperation -> Anchor +generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp + +setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN +setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) = + SrcSpanAnn (EpAnn anc nameAnn comments) span +setAnchor _ spanAnnN = spanAnnN + +removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN +removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) = + let nameAnnSansTrailings = nameAnn {nann_trailing = []} + in SrcSpanAnn (EpAnn anc nameAnnSansTrailings comments) span +removeTrailingAnns spanAnnN = spanAnnN + +-- | Modify the type signature for the given IdP. This function handles splitting a multi-sig +-- SigD into multiple SigD if the type signature is changed. +-- +-- For example, update the type signature for `foo` from `Int` to `Bool`: +-- +-- - foo :: Int +-- + foo :: Bool +-- +-- - foo, bar :: Int +-- + bar :: Int +-- + foo :: Bool +-- +-- - foo, bar, baz :: Int +-- + bar, baz :: Int +-- + foo :: Bool +modifySigWithM :: + forall a m. + (HasDecls a, Monad m) => + IdP GhcPs -> + (LHsSigType GhcPs -> LHsSigType GhcPs) -> + a -> + TransformT m a +modifySigWithM queryId f a = do + let modifyMatchingSigD :: [LHsDecl GhcPs] -> TransformT m (DL.DList (LHsDecl GhcPs)) + modifyMatchingSigD [] = pure DL.empty + modifyMatchingSigD (ldecl@(L annSigD (SigD xsig (TypeSig xTypeSig ids (HsWC xHsWc lHsSig)))) : rest) + | queryId `elem` (unLoc <$> ids) = do + let newSig = f lHsSig + -- If this signature update caused no change, then we don't need to split up multi-signatures + if newSig `geq` lHsSig + then pure $ DL.singleton ldecl <> DL.fromList rest + else case partition ((== queryId) . unLoc) ids of + ([L annMatchedId matchedId], otherIds) -> + let matchedId' = L (setAnchor genAnchor0 $ removeTrailingAnns annMatchedId) matchedId + matchedIdSig = + let sig' = SigD xsig (TypeSig xTypeSig [matchedId'] (HsWC xHsWc newSig)) + epAnn = bool (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 0)) annSigD (null otherIds) + in L epAnn sig' + otherSig = case otherIds of + [] -> [] + (L (SrcSpanAnn epAnn span) id1:ids) -> [ + let epAnn' = case epAnn of + EpAnn _ nameAnn commentsId1 -> EpAnn genAnchor0 nameAnn commentsId1 + EpAnnNotUsed -> EpAnn genAnchor0 mempty emptyComments + ids' = L (SrcSpanAnn epAnn' span) id1:ids + ids'' = ids' & _last %~ first removeTrailingAnns + in L annSigD (SigD xsig (TypeSig xTypeSig ids'' (HsWC xHsWc lHsSig))) + ] + in pure $ DL.fromList otherSig <> DL.singleton matchedIdSig <> DL.fromList rest + _ -> error "multiple ids matched" + modifyMatchingSigD (ldecl : rest) = (DL.singleton ldecl <>) <$> modifyMatchingSigD rest + modifyDeclsT (fmap DL.toList . modifyMatchingSigD) a + +genAnchor0 :: Anchor +genAnchor0 = generatedAnchor m0 + +genAnchor1 :: Anchor +genAnchor1 = generatedAnchor m1 + +-- | Apply a transformation to the decls contained in @t@ +modifyDeclsT' :: (HasDecls t, HasTransform m) + => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r)) + -> t -> m (t, r) +modifyDeclsT' action t = do + decls <- liftT $ hsDecls t + (decls', r) <- action decls + t' <- liftT $ replaceDecls t decls' + pure (t', r) + +-- | Modify each LMatch in a MatchGroup +modifyMgMatchesT :: + Monad m => + MatchGroup GhcPs (LHsExpr GhcPs) -> + (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))) -> + TransformT m (MatchGroup GhcPs (LHsExpr GhcPs)) +modifyMgMatchesT mg f = fst <$> modifyMgMatchesT' mg (fmap (, ()) . f) () ((.) pure . const) + +-- | Modify the each LMatch in a MatchGroup +modifyMgMatchesT' :: + Monad m => + MatchGroup GhcPs (LHsExpr GhcPs) -> + (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs), r)) -> + r -> + (r -> r -> m r) -> + TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r) +#if MIN_VERSION_ghc(9,5,0) +modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do + (unzip -> (matches', rs)) <- mapM f matches + r' <- TransformT $ lift $ foldM combineResults def rs + pure $ (MG xMg (L locMatches matches'), r') +#else +modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do + (unzip -> (matches', rs)) <- mapM f matches + r' <- lift $ foldM combineResults def rs + pure (MG xMg (L locMatches matches') originMg, r') +#endif + +graftSmallestDeclsWithM :: + forall a. + (HasDecls a) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> + Graft (Either String) a +graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | dst `isSubspanOf` locA src = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + +graftDeclsWithM :: + forall a m. + (HasDecls a, Fail.MonadFail m) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> + Graft m a +graftDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | locA src `eqSrcSpan` dst = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + hoistTransform (either Fail.fail pure) $ + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + + +-- In 9.2+, we need `Default l` to do `setPrecedingLines` on annotated elements. +-- In older versions, we pass around annotations explicitly, so the instance isn't needed. +class + ( Data ast + , Typeable l + , Outputable l + , Outputable ast + , Default l + ) => ASTElement l ast | ast -> l where + parseAST :: Parser (LocatedAn l ast) + maybeParensAST :: LocatedAn l ast -> LocatedAn l ast + {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with + the given @Located ast@. The node at that position must already be + a @Located ast@, or this is a no-op. + -} + graft :: + forall a. + (Data a) => + SrcSpan -> + LocatedAn l ast -> + Graft (Either String) a + graft dst = graft' True dst . maybeParensAST + +instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where + parseAST = parseExpr + maybeParensAST = parenthesize + graft = graftExpr + +instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where + parseAST = parsePattern + maybeParensAST = parenthesizePat appPrec + +instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where + parseAST = parseType + maybeParensAST = parenthesizeHsType appPrec + +instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where + parseAST = parseDecl + maybeParensAST = id + +instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where + parseAST = parseImport + maybeParensAST = id + +instance ASTElement NameAnn RdrName where + parseAST df fp = parseWith df fp parseIdentifier + maybeParensAST = id + +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ + + +-- | Given an 'LHSExpr', compute its exactprint annotations. +-- Note that this function will throw away any existing annotations (and format) +annotate :: ASTElement l ast + => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) +annotate dflags needs_space ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast +#if MIN_VERSION_ghc(9,4,0) + expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered + pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space) +#else + expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered + pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space) +#endif + +-- | Given an 'LHsDecl', compute its exactprint annotations. +annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) +annotateDecl dflags ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast +#if MIN_VERSION_ghc(9,4,0) + expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered + pure $ setPrecedingLines expr' 1 0 +#else + expr' <- lift $ mapLeft show $ parseDecl dflags uniq rendered + pure $ setPrecedingLines expr' 1 0 +#endif + +------------------------------------------------------------------------------ + +-- | Print out something 'Outputable'. +render :: Outputable a => DynFlags -> a -> String +render dflags = showSDoc dflags . ppr + +------------------------------------------------------------------------------ + +-- | Put parentheses around an expression if required. +parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs +parenthesize = parenthesizeHsExpr appPrec + +------------------------------------------------------------------------------ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +eqSrcSpan :: SrcSpan -> SrcSpan -> Bool +eqSrcSpan l r = leftmost_smallest l r == EQ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool +eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ + +addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext +addParensToCtxt close_dp = addOpen . addClose + where + addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]} + addOpen other = other + addClose it + | Just c <- close_dp = it{ac_close = [c]} + | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]} + | otherwise = it + +epl :: Int -> EpaLocation +epl n = EpaDelta (SameLine n) [] + +epAnn :: SrcSpan -> ann -> EpAnn ann +epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments + +modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast +modifyAnns x f = first ((fmap.fmap) f) x + +removeComma :: SrcSpanAnnA -> SrcSpanAnnA +removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it +removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) + = SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l + where + isCommaAnn AddCommaAnn{} = True + isCommaAnn _ = False + +addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn +addParens True it@NameAnn{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnCommas{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnOnly{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True NameAnnTrailing{..} = + NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..} +addParens _ it = it + +removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast +removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l + +isCommaAnn :: TrailingAnn -> Bool +isCommaAnn AddCommaAnn{} = True +isCommaAnn _ = False diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -0,0 +1,2005 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} + +module Development.IDE.Plugin.CodeAction + ( + mkExactprintPluginDescriptor, + iePluginDescriptor, + typeSigsPluginDescriptor, + bindingsPluginDescriptor, + fillHolePluginDescriptor, + extendImportPluginDescriptor, + -- * For testing + matchRegExMultipleImports + ) where + +import Control.Applicative ((<|>)) +import Control.Applicative.Combinators.NonEmpty (sepBy1) +import Control.Arrow (second, + (&&&), + (>>>)) +import Control.Concurrent.STM.Stats (atomically) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans +import Control.Monad.Trans.Except (ExceptT (ExceptT)) +import Control.Monad.Trans.Maybe +import Data.Char +import qualified Data.DList as DL +import Data.Function +import Data.Functor +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import Data.List.Extra +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Ord (comparing) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.GHC.Compat hiding + (ImplicitPrelude) +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as E +import Development.IDE.GHC.Util (printOutputable, + printRdrName) +import Development.IDE.Plugin.CodeAction.Args +import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.PositionIndexed +import Development.IDE.Plugin.CodeAction.Util +import Development.IDE.Plugin.Completions.Types +import qualified Development.IDE.Plugin.Plugins.AddArgument +import Development.IDE.Plugin.Plugins.Diagnostic +import Development.IDE.Plugin.Plugins.FillHole (suggestFillHole) +import Development.IDE.Plugin.Plugins.FillTypeWildcard (suggestFillTypeWildcard) +import Development.IDE.Plugin.Plugins.ImportUtils +import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Types.Exports +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import GHC (AddEpAnn (AddEpAnn), + Anchor (anchor_op), + AnchorOperation (..), + AnnsModule (am_main), + DeltaPos (..), + EpAnn (..), + EpaLocation (..), + LEpaComment) +import GHC.Exts (fromList) +import qualified GHC.LanguageExtensions as Lang +import Ide.Logger hiding + (group) +import Ide.PluginUtils (extendToFullLines, + extractTextInRange, + subRange) +import Ide.Types +import Language.LSP.Protocol.Message (Method (..), + SMethod (..)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), + CodeAction (..), + CodeActionKind (CodeActionKind_QuickFix), + CodeActionParams (CodeActionParams), + Command, + Diagnostic (..), + MessageType (..), + Null (Null), + ShowMessageParams (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit, _range), + UInt, + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (InL, InR), + uriToFilePath) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS (virtualFileText) +import qualified Text.Fuzzy.Parallel as TFP +import qualified Text.Regex.Applicative as RE +import Text.Regex.TDFA ((=~), (=~~)) + +------------------------------------------------------------------------------------------------- + +-- | Generate code actions. +codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do + contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + liftIO $ do + let text = virtualFileText <$> contents + mbFile = toNormalizedFilePath' <$> uriToFilePath uri + allDiags <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile + let + actions = caRemoveRedundantImports parsedModule text allDiags range uri + <> caRemoveInvalidExports parsedModule text allDiags range uri + pure $ InL actions + +------------------------------------------------------------------------------------------------- + +iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +iePluginDescriptor recorder plId = + let old = + mkGhcideCAsPlugin [ + wrap suggestExportUnusedTopBinding + , wrap suggestModuleTypo + , wrap suggestFixConstructorImport + , wrap suggestExtendImport + , wrap suggestImportDisambiguation + , wrap suggestNewOrExtendImportForClassMethod + , wrap suggestHideShadow + , wrap suggestNewImport + , wrap suggestAddRecordFieldImport + ] + plId + "Provides various quick fixes" + in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler SMethod_TextDocumentCodeAction codeAction } + +typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ + mkGhcideCAsPlugin [ + wrap $ suggestSignature True + , wrap suggestFillTypeWildcard + , wrap suggestAddTypeAnnotationToSatisfyConstraints + , wrap removeRedundantConstraints + , wrap suggestConstraint + ] + plId + "Provides various quick fixes for type signatures" + +bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ + mkGhcideCAsPlugin [ + wrap suggestReplaceIdentifier + , wrap suggestImplicitParameter + , wrap suggestNewDefinition + , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin + , wrap suggestDeleteUnusedBinding + ] + plId + "Provides various quick fixes for bindings" + +fillHolePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +fillHolePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder (mkGhcideCAPlugin (wrap suggestFillHole) plId "Provides a code action to fill a hole") + +extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId "Provides a command to extend the import list") + { pluginCommands = [extendImportCommand] } + + +-- | Add the ability for a plugin to call GetAnnotatedParsedSource +mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a +mkExactprintPluginDescriptor recorder desc = desc { pluginRules = pluginRules desc >> getAnnotatedParsedSourceRule recorder } + +------------------------------------------------------------------------------------------------- + + +extendImportCommand :: PluginCommand IdeState +extendImportCommand = + PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler + +extendImportHandler :: CommandFunction IdeState ExtendImport +extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do + let (_, head -> TextEdit {_range}) = fromJust $ _changes >>= listToMaybe . M.toList + srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> printOutputable srcSpan + <> ")" + void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right $ InR Null + +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) +extendImportHandler' ideState ExtendImport {..} + | Just fp <- uriToFilePath doc, + nfp <- toNormalizedFilePath' fp = + do + (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ + runAction "extend import" ideState $ + runMaybeT $ do + -- We want accurate edits, so do not use stale data here + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + ps <- MaybeT $ use GetAnnotatedParsedSource nfp + (_, contents) <- MaybeT $ use GetFileContents nfp + return (msr, ps, contents) + let df = ms_hspp_opts msrModSummary + wantedModule = mkModuleName (T.unpack importName) + wantedQual = mkModuleName . T.unpack <$> importQual + existingImport = find (isWantedModule wantedModule wantedQual) msrImports + case existingImport of + Just imp -> do + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc + $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) + + Nothing -> do + let qns = (,) <$> importQual <*> Just (qualifiedImportStyle df) + n = newImport importName sym qns False + sym = if isNothing importQual then Just it else Nothing + it = case thingParent of + Nothing -> newThing + Just p -> p <> "(" <> newThing <> ")" + t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) + return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc, [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) + | otherwise = + mzero + +isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool +isWantedModule wantedModule Nothing (L _ it@ImportDecl{ ideclName +#if MIN_VERSION_ghc(9,5,0) + , ideclImportList = Just (Exactly, _) +#else + , ideclHiding = Just (False, _) +#endif + }) = + not (isQualifiedImport it) && unLoc ideclName == wantedModule +isWantedModule wantedModule (Just qual) (L _ ImportDecl{ ideclAs, ideclName +#if MIN_VERSION_ghc(9,5,0) + , ideclImportList = Just (Exactly, _) +#else + , ideclHiding = Just (False, _) +#endif + }) = + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) +isWantedModule _ _ _ = False + + +liftMaybe :: Monad m => Maybe a -> MaybeT m a +liftMaybe a = MaybeT $ pure a + +liftEither :: Monad m => Either e a -> MaybeT m a +liftEither (Left _) = mzero +liftEither (Right x) = return x + +------------------------------------------------------------------------------------------------- + +findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDecl pred decls = + listToMaybe + [ sig + | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, + any (pred . unLoc) idsSig + ] + +findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDeclRanged range decls = do + dec <- findDeclContainingLoc (_start range) decls + case dec of + L _ (SigD _ sig@TypeSig {}) -> Just sig + L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind + _ -> Nothing + +findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p) +findSigOfBind range bind = + case bind of + FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) + _ -> Nothing + where + findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) + findSigOfLMatch ls = do + match <- findDeclContainingLoc (_start range) ls + let grhs = m_grhss $ unLoc match + msum + [findSigOfBinds range (grhssLocalBinds grhs) -- where clause + , do +#if MIN_VERSION_ghc(9,3,0) + grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) +#else + grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) +#endif + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + ] + + findSigOfExpr :: HsExpr p -> Maybe (Sig p) + findSigOfExpr = go + where +#if MIN_VERSION_ghc(9,3,0) + go (HsLet _ _ binds _ _) = findSigOfBinds range binds +#else + go (HsLet _ binds _) = findSigOfBinds range binds +#endif + go (HsDo _ _ stmts) = do + stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) + case stmtlr of + LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR + _ -> Nothing + go _ = Nothing + +findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p) +findSigOfBinds range = go + where + go (HsValBinds _ (ValBinds _ binds lsigs)) = + case unLoc <$> findDeclContainingLoc (_start range) lsigs of + Just sig' -> Just sig' + Nothing -> do + lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) + findSigOfBind range (unLoc lHsBindLR) + go _ = Nothing + +findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) +findInstanceHead df instanceHead decls = + listToMaybe + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] + +findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e) +findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) + +-- Single: +-- This binding for ‘mod’ shadows the existing binding +-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 +-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) +-- Multi: +--This binding for ‘pack’ shadows the existing bindings +-- imported from ‘Data.ByteString’ at B.hs:6:1-22 +-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 +-- imported from ‘Data.Text’ at B.hs:7:1-16 +suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] +suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} + | Just [identifier, modName, s] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = + suggests identifier modName s + | Just [identifier] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing bindings", + Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", + mods <- [(modName, s) | [_, modName, s] <- matched], + result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), + hideAll <- ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result) = + result <> [hideAll] + | otherwise = [] + where + L _ HsModule {hsmodImports} = astA ps + + suggests identifier modName s + | Just tcM <- mTcM, + Just har <- mHar, + [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents + else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] + +findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) +findImportDeclByModuleName decls modName = flip find decls $ \case + (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) + +isTheSameLine :: SrcSpan -> SrcSpan -> Bool +isTheSameLine s1 s2 + | Just sl1 <- getStartLine s1, + Just sl2 <- getStartLine s2 = + sl1 == sl2 + | otherwise = False + where + getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x + +isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool +isUnusedImportedId + TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} + HAR {refMap} + identifier + modName + importSpan + | occ <- mkVarOcc identifier, + impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, + Just rdrEnv <- + listToMaybe + [ imv_all_exports + | ImportedModsVal {..} <- impModsVals, + imv_name == mkModuleName modName, + isTheSameLine imv_span importSpan + ], + [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right name, + refs <- M.lookup importedIdentifier refMap = + maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs + | otherwise = False + +suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} +-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant + | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" + , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports + , Just c <- contents + , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) + , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) + , not (null ranges') + = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] + +-- File.hs:16:1: warning: +-- The import of `Data.List' is redundant +-- except perhaps to import instances from `Data.List' +-- To import instances alone, use: import Data.List() + | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) + = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] + | otherwise = [] + +diagInRange :: Diagnostic -> Range -> Bool +diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange + where + -- Ensures the range captures full lines. Makes it easier to trigger the correct + -- "remove redundant" code actions from anywhere on the offending line. + extendedRange = extendToFullLines r + +-- Note [Removing imports is preferred] +-- It's good to prefer the remove imports code action because an unused import +-- is likely to be removed and less likely the warning will be disabled. +-- Therefore actions to remove a single or all redundant imports should be +-- preferred, so that the client can prioritize them higher. +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveRedundantImports m contents allDiags contextRange uri + | Just pm <- m, + r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags, + allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], + caRemoveAll <- removeAll allEdits, + ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange], + not $ null ctxEdits, + caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [diagnostic] WorkspaceEdit{..} where + _changes = Just $ M.singleton uri tedit + _documentChanges = Nothing + _changeAnnotations = Nothing + removeAll tedit = InR $ CodeAction{..} where + _changes = Just $ M.singleton uri tedit + _title = "Remove all redundant imports" + _kind = Just CodeActionKind_QuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + -- See Note [Removing imports is preferred] + _isPreferred = Just True + _command = Nothing + _disabled = Nothing + _data_ = Nothing + _changeAnnotations = Nothing + +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveInvalidExports m contents allDiags contextRange uri + | Just pm <- m, + Just txt <- contents, + txt' <- indexedByPosition $ T.unpack txt, + r <- mapMaybe (groupDiag pm) allDiags, + r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, + caRemoveCtx <- mapMaybe removeSingle r', + allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], + allRanges' <- extend txt' allRanges, + Just caRemoveAll <- removeAll allRanges', + ctxEdits <- [ x | x@(_, d, _) <- r, d `diagInRange` contextRange], + not $ null ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges + + groupDiag pm dig + | Just (title, ranges) <- suggestRemoveRedundantExport pm dig + = Just (title, dig, ranges) + | otherwise = Nothing + + removeSingle (_, _, []) = Nothing + removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges + _changes = Just $ M.singleton uri tedit + _title = title + _kind = Just CodeActionKind_QuickFix + _diagnostics = Just [diagnostic] + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + -- See Note [Removing imports is preferred] + _isPreferred = Just True + _disabled = Nothing + _data_ = Nothing + _changeAnnotations = Nothing + removeAll [] = Nothing + removeAll ranges = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) ranges + _changes = Just $ M.singleton uri tedit + _title = "Remove all redundant exports" + _kind = Just CodeActionKind_QuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + -- See Note [Removing imports is preferred] + _isPreferred = Just True + _disabled = Nothing + _data_ = Nothing + _changeAnnotations = Nothing + +suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) +suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} + | msg <- unifySpaces _message + , Just export <- hsmodExports + , Just exportRange <- getLocatedRange $ reLoc export + , exports <- unLoc export + , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) + <|> (,[_range]) <$> matchExportItem msg + <|> (,[_range]) <$> matchDupExport msg + , subRange _range exportRange + = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) + where + matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" + matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" + getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of + [] -> (txt, [_range]) + ranges -> (txt, ranges) +suggestRemoveRedundantExport _ _ = Nothing + +suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBinding + ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} + contents + Diagnostic{_range=_range,..} +-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ + | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + , Just indexedContent <- indexedByPosition . T.unpack <$> contents + = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) + in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) + | otherwise = [] + where + relatedRanges indexedContent name = + concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls + toRange = realSrcSpanToRange + extendForSpaces = extendToIncludePreviousNewlineIfPossible + + findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] + findRelatedSpans + indexedContent + name + (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + case lname of + (L nLoc _name) | isTheBinding nLoc -> + let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in + extendForSpaces indexedContent (toRange l) : + concatMap (findSig . reLoc) hsmodDecls + _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpans _ _ _ = [] + + extractNameAndMatchesFromFunBind + :: HsBind GhcPs + -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) + extractNameAndMatchesFromFunBind + FunBind + { fun_id=lname + , fun_matches=MG {mg_alts=L _ matches} + } = Just (reLoc lname, matches) + extractNameAndMatchesFromFunBind _ = Nothing + + findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] + findRelatedSigSpan indexedContent name l sig = + let maybeSpan = findRelatedSigSpan1 name sig + in case maybeSpan of + Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int + Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused + _ -> [] + + -- Second of the tuple means there is only one match + findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) + findRelatedSigSpan1 name (TypeSig _ lnames _) = + let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames + in case maybeIdx of + Nothing -> Nothing + Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True) + Just idx -> + let targetLname = getLoc $ reLoc $ lnames !! idx + startLoc = srcSpanStart targetLname + endLoc = srcSpanEnd targetLname + startLoc' = if idx == 0 + then startLoc + else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1) + endLoc' = if idx == 0 && idx < length lnames - 1 + then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1) + else endLoc + in Just (mkSrcSpan startLoc' endLoc', False) + findRelatedSigSpan1 _ _ = Nothing + + -- for where clause + findRelatedSpanForMatch + :: PositionIndexedString + -> String + -> LMatch GhcPs (LHsExpr GhcPs) + -> [Range] + findRelatedSpanForMatch + indexedContent + name + (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do + let go bag lsigs = + if isEmptyBag bag + then [] + else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag + case grhssLocalBinds of + (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs + _ -> [] + + findRelatedSpanForHsBind + :: PositionIndexedString + -> String + -> [LSig GhcPs] + -> LHsBind GhcPs + -> [Range] + findRelatedSpanForHsBind + indexedContent + name + lsigs + (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + if isTheBinding (getLoc lname) + then + let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs + else concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpanForHsBind _ _ _ _ = [] + + isTheBinding :: SrcSpan -> Bool + isTheBinding span = srcSpanToRange span == Just _range + + isSameName :: IdP GhcPs -> String -> Bool + isSameName x name = T.unpack (printOutputable x) == name + +data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll + deriving (Eq) + +getLocatedRange :: HasSrcSpan a => a -> Maybe Range +getLocatedRange = srcSpanToRange . getLoc + +suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} +-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ +-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ +-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ + | Just source <- srcOpt + , Just [_, name] <- + matchRegexUnifySpaces + _message + ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’" + , Just (exportType, _) <- + find (matchWithDiagnostic _range . snd) + . mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing) + $ hsmodDecls + , Just exports <- fmap (fmap reLoc) . reLoc <$> hsmodExports + , Just exportsEndPos <- _end <$> getLocatedRange exports + , let name' = printExport exportType name + sep = exportSep source $ map getLocatedRange <$> exports + exportName = case sep of + Nothing -> (if needsComma source exports then ", " else "") <> name' + Just s -> s <> name' + exportsEndPos' = exportsEndPos { _character = pred $ _character exportsEndPos } + insertPos = fromMaybe exportsEndPos' $ case (sep, unLoc exports) of + (Just _, exports'@(_:_)) -> fmap _end . getLocatedRange $ last exports' + _ -> Nothing + = Just ("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName) + | otherwise = Nothing + where + exportSep :: T.Text -> Located [Maybe Range] -> Maybe T.Text + exportSep src (L (RealSrcSpan _ _) xs@(_ : tl@(_ : _))) = + case mapMaybe (\(e, s) -> (,) <$> e <*> s) $ zip (fmap _end <$> xs) (fmap _start <$> tl) of + [] -> Nothing + bounds -> Just smallestSep + where + smallestSep + = snd + $ minimumBy (comparing fst) + $ map (T.length &&& id) + $ nubOrd + $ map (\(prevEnd, nextStart) -> textInRange (Range prevEnd nextStart) src) bounds + exportSep _ _ = Nothing + + -- We get the last export and the closing bracket and check for comma in that range. + needsComma :: T.Text -> Located [Located (IE GhcPs)] -> Bool + needsComma _ (L _ []) = False + needsComma source (L (RealSrcSpan l _) exports) = + let closeParen = _end $ realSrcSpanToRange l + lastExport = fmap _end . getLocatedRange $ last exports + in + case lastExport of + Just lastExport -> + not $ T.any (== ',') $ textInRange (Range lastExport closeParen) source + _ -> False + needsComma _ _ = False + + opLetter :: T.Text + opLetter = ":!#$%&*+./<=>?@\\^|-~" + + parenthesizeIfNeeds :: Bool -> T.Text -> T.Text + parenthesizeIfNeeds needsTypeKeyword x + | T.any (c ==) opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <> ")" + | otherwise = x + where + c = T.head x + + matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool + matchWithDiagnostic Range{_start=l,_end=r} x = + let loc = fmap _start . getLocatedRange $ x + in loc >= Just l && loc <= Just r + + printExport :: ExportsAs -> T.Text -> T.Text + printExport ExportName x = parenthesizeIfNeeds False x + printExport ExportPattern x = "pattern " <> x + printExport ExportFamily x = parenthesizeIfNeeds True x + printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" + + isTopLevel :: SrcSpan -> Bool + isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0 + + exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs)) + exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, reLoc fun_id) + exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id) + exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, reLoc tcdLName) + exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportFamily, reLoc $ fdLName tcdFam) + exportsAs _ = Nothing + +suggestAddTypeAnnotationToSatisfyConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestAddTypeAnnotationToSatisfyConstraints sourceOpt Diagnostic{_range=_range,..} +-- File.hs:52:41: warning: +-- * Defaulting the following constraint to type ‘Integer’ +-- Num p0 arising from the literal ‘1’ +-- * In the expression: 1 +-- In an equation for ‘f’: f = 1 +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:228:7-25 +-- (IsString a0) +-- arising from the literal ‘"debug"’ +-- at A.hs:228:17-23 +-- * In the expression: traceShow "debug" a +-- In an equation for ‘f’: f a = traceShow "debug" a +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:255:28-43 +-- (IsString a0) +-- arising from the literal ‘"test"’ +-- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 +-- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ +-- In the expression: seq "test" seq "test" (traceShow "test") +-- In an equation for ‘f’: +-- f = seq "test" seq "test" (traceShow "test") +-- + | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) + <|> matchRegexUnifySpaces _message (pat False False False True) + <|> matchRegexUnifySpaces _message (pat False False False False) + + = codeEdit _range ty lit (makeAnnotatedLit ty lit) + | Just source <- sourceOpt + , Just [ty, lit, srcspan] <- matchRegexUnifySpaces _message (pat True True False False) + , range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + [s] -> let x = realSrcSpanToRange s + in x{_end = (_end x){_character = succ (_character (_end x))}} + _ -> error "bug in srcspan parser" + = let lit' = makeAnnotatedLit ty lit; + tir = textInRange range source + in codeEdit range ty lit (T.replace lit lit' tir) + | otherwise = [] + where + makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" +#if MIN_VERSION_ghc(9,4,0) + pat multiple at inArg inExpr = T.concat [ ".*Defaulting the type variable " + , ".*to type ‘([^ ]+)’ " + , "in the following constraint" + , if multiple then "s" else " " + , ".*arising from the literal ‘(.+)’" + , if inArg then ".+In the.+argument" else "" + , if at then ".+at ([^ ]*)" else "" + , if inExpr then ".+In the expression" else "" + , ".+In the expression" + ] +#else + pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" + , if multiple then "s" else "" + , " to type ‘([^ ]+)’ " + , ".*arising from the literal ‘(.+)’" + , if inArg then ".+In the.+argument" else "" + , if at then ".+at ([^ ]*)" else "" + , if inExpr then ".+In the expression" else "" + , ".+In the expression" + ] +#endif + codeEdit range ty lit replacement = + let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" + edits = [TextEdit range replacement] + in [( title, edits )] + +-- | GHC strips out backticks in case of infix functions as well as single quote +-- in case of quoted name when using TemplateHaskellQuotes. Which is not desired. +-- +-- For example: +-- 1. +-- +-- @ +-- File.hs:52:41: error: +-- * Variable not in scope: +-- suggestAcion :: Maybe T.Text -> Range -> Range +-- * Perhaps you meant ‘suggestAction’ (line 83) +-- File.hs:94:37: error: +-- Not in scope: ‘T.isPrfixOf’ +-- Perhaps you meant one of these: +-- ‘T.isPrefixOf’ (imported from Data.Text), +-- ‘T.isInfixOf’ (imported from Data.Text), +-- ‘T.isSuffixOf’ (imported from Data.Text) +-- Module ‘Data.Text’ does not export ‘isPrfixOf’. +-- @ +-- +-- * action: \`suggestAcion\` will be renamed to \`suggestAction\` keeping back ticks around the function +-- +-- 2. +-- +-- @ +-- import Language.Haskell.TH (Name) +-- foo :: Name +-- foo = 'bread +-- +-- File.hs:8:7: error: +-- Not in scope: ‘bread’ +-- * Perhaps you meant one of these: +-- ‘break’ (imported from Prelude), ‘read’ (imported from Prelude) +-- * In the Template Haskell quotation 'bread +-- @ +-- +-- * action: 'bread will be renamed to 'break keeping single quote on beginning of name +suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestReplaceIdentifier contents Diagnostic{_range=_range,..} + | renameSuggestions@(_:_) <- extractRenamableTerms _message + = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] + | otherwise = [] + +suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range} + | Just (name, typ) <- matchVariableNotInScope message = + newDefinitionAction ideOptions parsedModule _range name typ + | Just (name, typ) <- matchFoundHole message, + [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name (Just typ) = + [(label, mkRenameEdit contents _range name : newDefinitionEdits)] + | otherwise = [] + where + message = unifySpaces _message + +newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])] +newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ + | Range _ lastLineP : _ <- + [ realSrcSpanToRange sp + | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls, + _start `isInsideSrcSpan` l + ], + nextLineP <- Position {_line = _line lastLineP + 1, _character = 0} = + [ ( "Define " <> sig, + [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])] + ) + ] + | otherwise = [] + where + colon = if optNewColonConvention then " : " else " :: " + sig = name <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ) + ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule + +{- Handles two variants with different formatting + +1. Could not find module ‘Data.Cha’ + Perhaps you meant Data.Char (from base-4.12.0.0) + +2. Could not find module ‘Data.I’ + Perhaps you meant + Data.Ix (from base-4.14.3.0) + Data.Eq (from base-4.14.3.0) + Data.Int (from base-4.14.3.0) +-} +suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] +suggestModuleTypo Diagnostic{_range=_range,..} + | "Could not find module" `T.isInfixOf` _message = + case T.splitOn "Perhaps you meant" _message of + [_, stuff] -> + [ ("replace with " <> modul, TextEdit _range modul) + | modul <- mapMaybe extractModule (T.lines stuff) + ] + _ -> [] + | otherwise = [] + where + extractModule line = case T.words line of + [modul, "(from", _] -> Just modul + _ -> Nothing + +suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] +suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} + | Just [binding, mod, srcspan] <- + matchRegexUnifySpaces _message +#if MIN_VERSION_ghc(9,7,0) + "Add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\(at (.*)\\)\\." +#else + "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)\\." +#endif + = suggestions hsmodImports binding mod srcspan + | Just (binding, mod_srcspan) <- + matchRegExMultipleImports _message + = mod_srcspan >>= uncurry (suggestions hsmodImports binding) + | otherwise = [] + where + canUseDatacon = case extractNotInScopeName _message of + Just NotInScopeTypeConstructorOrClass{} -> False + _ -> True + + suggestions decls binding mod srcspan + | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + [s] -> let x = realSrcSpanToRange s + in x{_end = (_end x){_character = succ (_character (_end x))}} + _ -> error "bug in srcspan parser", + Just decl <- findImportDeclByRange decls range, + Just ident <- lookupExportMap binding mod + = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod + , quickFixImportKind' "extend" importStyle + , uncurry extendImport (unImportStyle importStyle) decl + ) + | importStyle <- NE.toList $ importStyles ident + ] + | otherwise = [] + lookupExportMap binding mod + | let em = getExportsMap exportsMap +#if MIN_VERSION_ghc(9,7,0) + match = mconcat $ lookupOccEnv_AllNameSpaces em (mkVarOrDataOcc binding) +#else + match1 = lookupOccEnv em (mkVarOrDataOcc binding) + match2 = lookupOccEnv em (mkTypeOcc binding) + , Just match <- match1 <> match2 +#endif + -- Only for the situation that data constructor name is same as type constructor name, + -- let ident with parent be in front of the one without. + , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) + , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch + , (ident:_) <- idents -- Ensure fallback while `idents` is empty + = Just ident + + -- fallback to using GHC suggestion even though it is not always correct + | otherwise + = Just IdentInfo + { name = mkVarOrDataOcc binding + , parent = Nothing + , identModuleName = mkModuleNameFS $ mkFastStringByteString $ T.encodeUtf8 mod} + +data HidingMode + = HideOthers [ModuleTarget] + | ToQualified + Bool + -- ^ Parenthesised? + ModuleName + +data ModuleTarget + = ExistingImp (NonEmpty (LImportDecl GhcPs)) + | ImplicitPrelude [LImportDecl GhcPs] + +targetImports :: ModuleTarget -> [LImportDecl GhcPs] +targetImports (ExistingImp ne) = NE.toList ne +targetImports (ImplicitPrelude xs) = xs + +oneAndOthers :: [a] -> [(a, [a])] +oneAndOthers = go + where + go [] = [] + go (x : xs) = (x, xs) : map (second (x :)) (go xs) + +isPreludeImplicit :: DynFlags -> Bool +isPreludeImplicit = xopt Lang.ImplicitPrelude + +-- | Suggests disambiguation for ambiguous symbols. +suggestImportDisambiguation :: + DynFlags -> + Maybe T.Text -> + Annotated ParsedSource -> + T.Text -> + Diagnostic -> + [(T.Text, [Either TextEdit Rewrite])] +suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..} + | Just [ambiguous] <- + matchRegexUnifySpaces + _message + "Ambiguous occurrence ‘([^’]+)’" + , Just modules <- + map last + <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" + , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" = + suggestions ambiguous modules (isJust local) + | otherwise = [] + where + L _ HsModule {hsmodImports} = astA ps + + locDic = + fmap (NE.fromList . DL.toList) $ + Map.fromListWith (<>) $ + map + ( \i@(L _ idecl) -> + ( T.pack $ moduleNameString $ unLoc $ ideclName idecl + , DL.singleton i + ) + ) + hsmodImports + toModuleTarget "Prelude" + | isPreludeImplicit df + = Just $ ImplicitPrelude $ + maybe [] NE.toList (Map.lookup "Prelude" locDic) + toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic + parensed = + "(" `T.isPrefixOf` T.strip (textInRange _range txt) + -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] + removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort + hasDuplicate xs = length xs /= length (S.fromList xs) + suggestions symbol mods local + | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of + Just targets -> suggestionsImpl symbol (map (, []) targets) local + Nothing -> [] + | otherwise = case mapM toModuleTarget mods of + Just targets -> suggestionsImpl symbol (oneAndOthers targets) local + Nothing -> [] + suggestionsImpl symbol targetsWithRestImports local = + sortOn fst + [ ( renderUniquify mode modNameText symbol False + , disambiguateSymbol ps fileContents diag symbol mode + ) + | (modTarget, restImports) <- targetsWithRestImports + , let modName = targetModuleName modTarget + modNameText = T.pack $ moduleNameString modName + , mode <- + [ ToQualified parensed qual + | ExistingImp imps <- [modTarget] + {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} + -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation + -- nubOrd can't be used since SrcSpan is intentionally no Ord + , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) + $ NE.toList imps + ] + ++ [ToQualified parensed modName + | any (occursUnqualified symbol . unLoc) + (targetImports modTarget) + || case modTarget of + ImplicitPrelude{} -> True + _ -> False + ] + ++ [HideOthers restImports | not (null restImports)] + ] ++ [ ( renderUniquify mode T.empty symbol True + , disambiguateSymbol ps fileContents diag symbol mode + ) | local, not (null targetsWithRestImports) + , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) + ] + renderUniquify HideOthers {} modName symbol local = + "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports" + renderUniquify (ToQualified _ qual) _ symbol _ = + "Replace with qualified: " + <> T.pack (moduleNameString qual) + <> "." + <> symbol +suggestImportDisambiguation _ _ _ _ _ = [] + +occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool +occursUnqualified symbol ImportDecl{..} + | isNothing ideclAs = Just False /= + -- I don't find this particularly comprehensible, + -- but HLint suggested me to do so... +#if MIN_VERSION_ghc(9,5,0) + (ideclImportList <&> \(isHiding, L _ ents) -> + let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents + in (isHiding == EverythingBut) && not occurs || (isHiding == Exactly) && occurs + ) +#else + (ideclHiding <&> \(isHiding, L _ ents) -> + let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents + in isHiding && not occurs || not isHiding && occurs + ) +#endif +occursUnqualified _ _ = False + +symbolOccursIn :: T.Text -> IE GhcPs -> Bool +symbolOccursIn symb = any ((== symb). printOutputable) . ieNames + +targetModuleName :: ModuleTarget -> ModuleName +targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" +targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = + unLoc ideclName + +disambiguateSymbol :: + Annotated ParsedSource -> + T.Text -> + Diagnostic -> + T.Text -> + HidingMode -> + [Either TextEdit Rewrite] +disambiguateSymbol ps fileContents Diagnostic {..} (T.unpack -> symbol) = \case + (HideOthers hiddens0) -> + [ Right $ hideSymbol symbol idecl + | ExistingImp idecls <- hiddens0 + , idecl <- NE.toList idecls + ] + ++ mconcat + [ if null imps + then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) ps fileContents + else Right . hideSymbol symbol <$> imps + | ImplicitPrelude imps <- hiddens0 + ] + (ToQualified parensed qualMod) -> + let occSym = mkVarOcc symbol + rdr = Qual qualMod occSym + in Right <$> [ if parensed + then Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @(HsExpr GhcPs) df $ + T.unpack $ printOutputable $ + HsVar @GhcPs noExtField $ + reLocA $ L (mkGeneralSrcSpan "") rdr + else Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @RdrName df $ + T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr + ] + +findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) +findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs + +suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] +suggestFixConstructorImport Diagnostic{_range=_range,..} + -- ‘Success’ is a data constructor of ‘Result’ + -- To import it use + -- import Data.Aeson.Types( Result( Success ) ) + -- or + -- import Data.Aeson.Types( Result(..) ) (lsp-ui) + -- + -- On 9.8+ + -- + -- In the import of ‘ModuleA’: + -- an item called ‘Constructor’ + -- is exported, but it is a data constructor of + -- ‘A’. + | Just [constructor, typ] <- + matchRegexUnifySpaces _message +#if MIN_VERSION_ghc(9,7,0) + "an item called ‘([^’]*)’ is exported, but it is a data constructor of ‘([^’]*)’" +#else + "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" +#endif + = let fixedImport = typ <> "(" <> constructor <> ")" + in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] + | otherwise = [] + +suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..} + | Just fieldName <- findMissingField _message + , Just (range, indent) <- newImportInsertRange ps fileContents + = let qis = qualifiedImportStyle df + suggestions = nubSortBy simpleCompareImportSuggestion (constructNewImportSuggestions exportsMap (Nothing, NotInScopeThing fieldName) Nothing qis) + in map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions + | otherwise = [] + where + findMissingField :: T.Text -> Maybe T.Text + findMissingField t = + let + hasfieldRegex = "((.+\\.)?HasField) \"(.+)\" ([^ ]+) ([^ ]+)" + regex = "(No instance for|Could not deduce):? (\\(" <> hasfieldRegex <> "\\)|‘" <> hasfieldRegex <> "’|" <> hasfieldRegex <> ")" + match = filter (/="") <$> matchRegexUnifySpaces t regex + in case match of + Just [_, _, _, _, fieldName, _, _] -> Just fieldName + _ -> Nothing + +-- | Suggests a constraint for a declaration for which a constraint is missing. +suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} + | Just missingConstraint <- findMissingConstraint _message + = let codeAction = if _message =~ ("the type signature for:" :: String) + then suggestFunctionConstraint df parsedModule + else suggestInstanceConstraint df parsedModule + in codeAction diag missingConstraint + | otherwise = [] + where + findMissingConstraint :: T.Text -> Maybe T.Text + findMissingConstraint t = + let -- The regex below can be tested at: + -- https://regex101.com/r/dfSivJ/1 + regex = "(No instance for|Could not deduce):? (\\((.+)\\)|‘(.+)’|.+) arising from" -- a use of / a do statement + + match = matchRegexUnifySpaces t regex + + -- For a string like: + -- "Could not deduce: ?a::() arising from" + -- The `matchRegexUnifySpaces` function returns two empty match + -- groups at the end of the list. It's not clear why this is the + -- case, so we select the last non-empty match group. + getCorrectGroup = last . filter (/="") + + in getCorrectGroup <$> match + +-- | Suggests a constraint for an instance declaration for which a constraint is missing. +suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint + | Just instHead <- instanceHead + = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] + | otherwise = [] + where + instanceHead + -- Suggests a constraint for an instance declaration with no existing constraints. + -- • No instance for (Eq a) arising from a use of ‘==’ + -- Possible fix: add (Eq a) to the context of the instance declaration + -- • In the expression: x == y + -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y + -- In the instance declaration for ‘Eq (Wrap a)’ + | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" + , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls + = Just instHead + -- Suggests a constraint for an instance declaration with one or more existing constraints. + -- • Could not deduce (Eq b) arising from a use of ‘==’ + -- from the context: Eq a + -- bound by the instance declaration at /path/to/Main.hs:7:10-32 + -- Possible fix: add (Eq b) to the context of the instance declaration + -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ + -- In the expression: x == y && x' == y' + -- In an equation for ‘==’: + -- (Pair x x') == (Pair y y') = x == y && x' == y' + | Just [instanceLineStr, constraintFirstCharStr] + <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})}))) + <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls + = Just hsib_body + | otherwise + = Nothing + + readPositionNumber :: T.Text -> UInt + readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral + + actionTitle :: T.Text -> T.Text + actionTitle constraint = "Add `" <> constraint + <> "` to the context of the instance declaration" + +suggestImplicitParameter :: + ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} + | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, + Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})}) + <- findSigOfDecl (== funId) hsmodDecls + = + [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) + , appendConstraint (T.unpack implicitT) hsib_body)] + | otherwise = [] + +findTypeSignatureName :: T.Text -> Maybe T.Text +findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head + +-- | Suggests a constraint for a type signature with any number of existing constraints. +suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint +-- • No instance for (Eq a) arising from a use of ‘==’ +-- Possible fix: +-- add (Eq a) to the context of +-- the type signature for: +-- eq :: forall a. a -> a -> Bool +-- • In the expression: x == y +-- In an equation for ‘eq’: eq x y = x == y + +-- • Could not deduce (Eq b) arising from a use of ‘==’ +-- from the context: Eq a +-- bound by the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- at Main.hs:5:1-42 +-- Possible fix: +-- add (Eq b) to the context of +-- the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- • In the second argument of ‘(&&)’, namely ‘y == y'’ +-- In the expression: x == x' && y == y' +-- In an equation for ‘eq’: +-- eq (Pair x y) (Pair x' y') = x == x' && y == y' + | Just typeSignatureName <- findTypeSignatureName _message + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) + <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls + , title <- actionTitle missingConstraint typeSignatureName + = [(title, appendConstraint (T.unpack missingConstraint) sig)] + | otherwise + = [] + where + actionTitle :: T.Text -> T.Text -> T.Text + actionTitle constraint typeSignatureName = "Add `" <> constraint + <> "` to the context of the type signature for `" <> typeSignatureName <> "`" + +-- | Suggests the removal of a redundant constraint for a type signature. +removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..} +-- • Redundant constraint: Eq a +-- • In the type signature for: +-- foo :: forall a. Eq a => a -> a +-- • Redundant constraints: (Monoid a, Show a) +-- • In the type signature for: +-- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool + -- Account for both "Redundant constraint" and "Redundant constraints". + | "Redundant constraint" `T.isInfixOf` _message + , Just typeSignatureName <- findTypeSignatureName _message + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) + <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls + , Just redundantConstraintList <- findRedundantConstraints _message + , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig + = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] + | otherwise = [] + where + toRemove df list a = T.pack (showSDoc df (ppr a)) `elem` list + + parseConstraints :: T.Text -> [T.Text] + parseConstraints t = t + & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") + <&> T.strip + + stripConstraintsParens :: T.Text -> T.Text + stripConstraintsParens constraints = + if "(" `T.isPrefixOf` constraints + then constraints & T.drop 1 & T.dropEnd 1 & T.strip + else constraints + +{- +9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning: + ⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", + +9.0: "message": "⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", +-} + findRedundantConstraints :: T.Text -> Maybe [T.Text] + findRedundantConstraints t = t + & T.lines + -- In <9.2 it's the first line, in 9.2 it' the second line + & take 2 + & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) + & listToMaybe + <&> (head >>> parseConstraints) + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + actionTitle :: [T.Text] -> T.Text -> T.Text + actionTitle constraintList typeSignatureName = + "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" + <> formatConstraints constraintList + <> "` from the context of the type signature for `" <> typeSignatureName <> "`" + +------------------------------------------------------------------------------------------------- + +suggestNewOrExtendImportForClassMethod :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] +suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} + | Just [methodName, className] <- + matchRegexUnifySpaces + _message + "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", + idents <- + maybe [] (Set.toList . Set.filter (\x -> fmap occNameText (parent x) == Just className)) $ + lookupOccEnv (getExportsMap packageExportsMap) (mkVarOrDataOcc methodName) = + mconcat $ suggest <$> idents + | otherwise = [] + where + suggest identInfo + | importStyle <- NE.toList $ importStyles identInfo, + mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) = + case mImportDecl of + -- extend + Just decl -> + [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleText, + quickFixImportKind' "extend" style, + [Right $ uncurry extendImport (unImportStyle style) decl] + ) + | style <- importStyle + ] + -- new + _ + | Just (range, indent) <- newImportInsertRange ps fileContents + -> + (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$> + [ (quickFixImportKind' "new" style, newUnqualImport moduleText rendered False) + | style <- importStyle, + let rendered = renderImportStyle style + ] + <> [(quickFixImportKind "new.all", newImportAll moduleText)] + | otherwise -> [] + where moduleText = moduleNameText identInfo + +suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestNewImport df packageExportsMap ps fileContents Diagnostic{..} + | msg <- unifySpaces _message + , Just thingMissing <- extractNotInScopeName msg + , qual <- extractQualifiedModuleName msg + , qual' <- + extractDoesNotExportModuleName msg + >>= (findImportDeclByModuleName hsmodImports . T.unpack) + >>= ideclAs . unLoc + <&> T.pack . moduleNameString . unLoc + , -- tentative workaround for detecting qualification in GHC 9.4 + -- FIXME: We can delete this after dropping the support for GHC 9.4 + qualGHC94 <- + guard (ghcVersion == GHC94) + *> extractQualifiedModuleNameFromMissingName (extractTextInRange _range fileContents) + , Just (range, indent) <- newImportInsertRange ps fileContents + , extendImportSuggestions <- matchRegexUnifySpaces msg +#if MIN_VERSION_ghc(9,7,0) + "Add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" +#else + "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" +#endif + = let qis = qualifiedImportStyle df + -- FIXME: we can use thingMissing once the support for GHC 9.4 is dropped. + -- In what fllows, @missing@ is assumed to be qualified name. + -- @thingMissing@ is already as desired with GHC != 9.4. + -- In GHC 9.4, however, GHC drops a module qualifier from a qualified symbol. + -- Thus we need to explicitly concatenate qualifier explicity in GHC 9.4. + missing + | GHC94 <- ghcVersion + , isNothing (qual <|> qual') + , Just q <- qualGHC94 = + qualify q thingMissing + | otherwise = thingMissing + suggestions = nubSortBy simpleCompareImportSuggestion + (constructNewImportSuggestions packageExportsMap (qual <|> qual' <|> qualGHC94, missing) extendImportSuggestions qis) in + map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions + where + qualify q (NotInScopeDataConstructor d) = NotInScopeDataConstructor (q <> "." <> d) + qualify q (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (q <> "." <> d) + qualify q (NotInScopeThing d) = NotInScopeThing (q <> "." <> d) + + L _ HsModule {..} = astA ps +suggestNewImport _ _ _ _ _ = [] + +{- | +Extracts qualifier of the symbol from the missing symbol. +Input must be either a plain qualified variable or possibly-parenthesized qualified binary operator (though no strict checking is done for symbol part). +This is only needed to alleviate the issue #3473. + +FIXME: We can delete this after dropping the support for GHC 9.4 + +>>> extractQualifiedModuleNameFromMissingName "P.lookup" +Just "P" + +>>> extractQualifiedModuleNameFromMissingName "ΣP3_'.σlookup" +Just "\931P3_'" + +>>> extractQualifiedModuleNameFromMissingName "ModuleA.Gre_ekσ.goodδ" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ.+)" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ..|.)" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "A.B.|." +Just "A.B" +-} +extractQualifiedModuleNameFromMissingName :: T.Text -> Maybe T.Text +extractQualifiedModuleNameFromMissingName (T.strip -> missing) + = T.pack <$> (T.unpack missing RE.=~ qualIdentP) + where + {- + NOTE: Haskell 2010 allows /unicode/ upper & lower letters + as a module name component; otoh, regex-tdfa only allows + /ASCII/ letters to be matched with @[[:upper:]]@ and/or @[[:lower:]]@. + Hence we use regex-applicative(-text) for finer-grained predicates. + + RULES (from [Section 10 of Haskell 2010 Report](https://www.haskell.org/onlinereport/haskell2010/haskellch10.html)): + modid → {conid .} conid + conid → large {small | large | digit | ' } + small → ascSmall | uniSmall | _ + ascSmall → a | b | … | z + uniSmall → any Unicode lowercase letter + large → ascLarge | uniLarge + ascLarge → A | B | … | Z + uniLarge → any uppercase or titlecase Unicode letter + -} + + qualIdentP = parensQualOpP <|> qualVarP + parensQualOpP = RE.sym '(' *> modNameP <* RE.sym '.' <* RE.anySym <* RE.few RE.anySym <* RE.sym ')' + qualVarP = modNameP <* RE.sym '.' <* RE.some RE.anySym + conIDP = RE.withMatched $ + RE.psym isUpper + *> RE.many + (RE.psym $ \c -> c == '\'' || c == '_' || isUpper c || isLower c || isDigit c) + modNameP = fmap snd $ RE.withMatched $ conIDP `sepBy1` RE.sym '.' + + +constructNewImportSuggestions + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion] +constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion + [ suggestion + | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name + , identInfo <- maybe [] Set.toList $ lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name) + <> lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name) -- look up the modified unknown name in the export map + , canUseIdent thingMissing identInfo -- check if the identifier information retrieved can be used + , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules -- check if the module of the identifier is allowed + , suggestion <- renderNewImport identInfo -- creates a list of import suggestions for the retrieved identifier information + ] + where + renderNewImport :: IdentInfo -> [ImportSuggestion] + renderNewImport identInfo + | Just q <- qual + = [ImportSuggestion importanceScore (quickFixImportKind "new.qualified") (newQualImport m q qis)] + | otherwise + = [ImportSuggestion importanceScore (quickFixImportKind' "new" importStyle) (newUnqualImport m (renderImportStyle importStyle) False) + | importStyle <- NE.toList $ importStyles identInfo] ++ + [ImportSuggestion importanceScore (quickFixImportKind "new.all") (newImportAll m)] + where + -- The importance score takes 2 metrics into account. The first being the similarity using + -- the Text.Fuzzy.Parallel.match function. The second is a factor of the relation between + -- the modules prefix import suggestion and the unknown identifier names. + importanceScore + | Just q <- qual + = let + similarityScore = fromIntegral $ unpackMatchScore (TFP.match (T.toLower q) (T.toLower m)) :: Double + (maxLength, minLength) = case (T.length q, T.length m) of + (la, lb) + | la >= lb -> (fromIntegral la, fromIntegral lb) + | otherwise -> (fromIntegral lb, fromIntegral la) + lengthPenaltyFactor = 100 * minLength / maxLength + in max 0 (floor (similarityScore * lengthPenaltyFactor)) + | otherwise + = 0 + where + unpackMatchScore pScore + | Just score <- pScore = score + | otherwise = 0 + m = moduleNameText identInfo + +data ImportSuggestion = ImportSuggestion !Int !CodeActionKind !NewImport + deriving ( Eq ) + +-- | Implements a lexicographic order for import suggestions that ignores the code action. +-- First it compares the importance score in DESCENDING order. +-- If the scores are equal it compares the import names alphabetical order. +-- +-- TODO: this should be a correct Ord instance but CodeActionKind does not implement a Ord +-- which would lead to an unlawful Ord instance. +simpleCompareImportSuggestion :: ImportSuggestion -> ImportSuggestion -> Ordering +simpleCompareImportSuggestion (ImportSuggestion s1 _ i1) (ImportSuggestion s2 _ i2) + = flip compare s1 s2 <> compare i1 i2 + +newtype NewImport = NewImport {unNewImport :: T.Text} + deriving (Show, Eq, Ord) + +newImportToEdit :: NewImport -> Annotated ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) +newImportToEdit (unNewImport -> imp) ps fileContents + | Just (range, indent) <- newImportInsertRange ps fileContents + = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " ")) + | otherwise = Nothing + +-- | Finds the next valid position for inserting a new import declaration +-- * If the file already has existing imports it will be inserted under the last of these, +-- it is assumed that the existing last import declaration is in a valid position +-- * If the file does not have existing imports, but has a (module ... where) declaration, +-- the new import will be inserted directly under this declaration (accounting for explicit exports) +-- * If the file has neither existing imports nor a module declaration, +-- the import will be inserted at line zero if there are no pragmas, +-- * otherwise inserted one line after the last file-header pragma +newImportInsertRange :: Annotated ParsedSource -> T.Text -> Maybe (Range, Int) +newImportInsertRange ps fileContents + | Just ((l, c), col) <- case hsmodImports of + -- When there is no existing imports, we only cares about the line number, setting column and indent to zero. + [] -> (\line -> ((line, 0), 0)) <$> findPositionNoImports ps fileContents + _ -> findPositionFromImports (map reLoc hsmodImports) last + , let insertPos = Position (fromIntegral l) (fromIntegral c) + = Just (Range insertPos insertPos, col) + | otherwise = Nothing + where + L _ HsModule {..} = astA ps + +-- | Find the position for a new import when there isn't an existing one. +-- * If there is a module declaration, a new import should be inserted under the module declaration (including exports list) +-- * Otherwise, a new import should be inserted after any file-header pragma. +findPositionNoImports :: Annotated ParsedSource -> T.Text -> Maybe Int +findPositionNoImports ps fileContents = + maybe (Just (findNextPragmaPosition fileContents)) (findPositionAfterModuleName ps) hsmodName + where + L _ HsModule {..} = astA ps + +-- | find line number right after module ... where +findPositionAfterModuleName :: Annotated ParsedSource + -> LocatedA ModuleName + -> Maybe Int +findPositionAfterModuleName ps hsmodName' = do + -- Note that 'where' keyword and comments are not part of the AST. They belongs to + -- the exact-print information. To locate it, we need to find the previous AST node, + -- calculate the gap between it and 'where', then add them up to produce the absolute + -- position of 'where'. + + lineOffset <- whereKeywordLineOffset -- Calculate the gap before 'where' keyword. + case prevSrcSpan of + UnhelpfulSpan _ -> Nothing + (RealSrcSpan prevSrcSpan' _) -> + -- add them up produce the absolute location of 'where' keyword + Just $ srcLocLine (realSrcSpanEnd prevSrcSpan') + lineOffset + where + L _ HsModule {..} = astA ps + + -- The last AST node before 'where' keyword. Might be module name or export list. + prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports + + -- The relative position of 'where' keyword (in lines, relative to the previous AST node). + -- The exact-print API changed a lot in ghc-9.2, so we need to handle it separately for different compiler versions. + whereKeywordLineOffset :: Maybe Int +#if MIN_VERSION_ghc(9,5,0) + whereKeywordLineOffset = case hsmodAnn hsmodExt of +#else + whereKeywordLineOffset = case hsmodAnn of +#endif + EpAnn _ annsModule _ -> do + -- Find the first 'where' + whereLocation <- fmap NE.head . NE.nonEmpty . mapMaybe filterWhere . am_main $ annsModule + epaLocationToLine whereLocation + EpAnnNotUsed -> Nothing + filterWhere (AddEpAnn AnnWhere loc) = Just loc + filterWhere _ = Nothing + + epaLocationToLine :: EpaLocation -> Maybe Int +#if MIN_VERSION_ghc(9,5,0) + epaLocationToLine (EpaSpan sp _) + = Just . srcLocLine . realSrcSpanEnd $ sp +#else + epaLocationToLine (EpaSpan sp) + = Just . srcLocLine . realSrcSpanEnd $ sp +#endif + epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments + -- 'priorComments' contains the comments right before the current EpaLocation + -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and + -- the current AST node + epaLocationToLine (EpaDelta (DifferentLine line _) priorComments) = Just (line + sumCommentsOffset priorComments) + + sumCommentsOffset :: [LEpaComment] -> Int + sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine (anchor_op anchor)) + + anchorOpLine :: AnchorOperation -> Int + anchorOpLine UnchangedAnchor = 0 + anchorOpLine (MovedAnchor (SameLine _)) = 0 + anchorOpLine (MovedAnchor (DifferentLine line _)) = line + +findPositionFromImports :: HasSrcSpan a => t -> (t -> a) -> Maybe ((Int, Int), Int) +findPositionFromImports hsField f = case getLoc (f hsField) of + RealSrcSpan s _ -> + let col = calcCol s + in Just ((srcLocLine (realSrcSpanEnd s), col), col) + _ -> Nothing + where calcCol s = srcLocCol (realSrcSpanStart s) - 1 + +-- | Find the position one after the last file-header pragma +-- Defaults to zero if there are no pragmas in file +findNextPragmaPosition :: T.Text -> Int +findNextPragmaPosition contents = lineNumber + where + lineNumber = afterLangPragma . afterOptsGhc $ afterShebang + afterLangPragma = afterPragma "LANGUAGE" contents' + afterOptsGhc = afterPragma "OPTIONS_GHC" contents' + afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0 + contents' = T.lines contents + +afterPragma :: T.Text -> [T.Text] -> Int -> Int +afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum + +lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int +lastLineWithPrefix p contents lineNum = max lineNum next + where + next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents + +checkPragma :: T.Text -> T.Text -> Bool +checkPragma name = check + where + check l = isPragma l && getName l == name + getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l + isPragma = T.isPrefixOf "{-#" + +-- | Construct an import declaration with at most one symbol +newImport + :: T.Text -- ^ module name + -> Maybe T.Text -- ^ the symbol + -> Maybe (T.Text, QualifiedImportStyle) -- ^ qualified name and style + -> Bool -- ^ the symbol is to be imported or hidden + -> NewImport +newImport modName mSymbol mQualNameStyle hiding = NewImport impStmt + where + symImp + | Just symbol <- mSymbol + , symOcc <- mkVarOcc $ T.unpack symbol = + " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")" + | otherwise = "" + impStmt = + "import " + <> qualifiedModName (snd <$> mQualNameStyle) + <> (if hiding then " hiding" else "") + <> symImp + <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual + mQual = fst <$> mQualNameStyle + qualifiedModName Nothing = modName + qualifiedModName (Just QualifiedImportPrefix) = "qualified " <> modName + qualifiedModName (Just QualifiedImportPostfix) = modName <> " qualified" + + +newQualImport :: T.Text -> T.Text -> QualifiedImportStyle -> NewImport +newQualImport modName qual qis = newImport modName Nothing (Just (qual, qis)) False + +newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport +newUnqualImport modName symbol = newImport modName (Just symbol) Nothing + +newImportAll :: T.Text -> NewImport +newImportAll modName = newImport modName Nothing Nothing False + +hideImplicitPreludeSymbol :: T.Text -> NewImport +hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True + +canUseIdent :: NotInScope -> IdentInfo -> Bool +canUseIdent NotInScopeDataConstructor{} = isDatacon +canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon +canUseIdent _ = const True + +data NotInScope + = NotInScopeDataConstructor T.Text + | NotInScopeTypeConstructorOrClass T.Text + | NotInScopeThing T.Text + deriving Show + +notInScope :: NotInScope -> T.Text +notInScope (NotInScopeDataConstructor t) = t +notInScope (NotInScopeTypeConstructorOrClass t) = t +notInScope (NotInScopeThing t) = t + +extractNotInScopeName :: T.Text -> Maybe NotInScope +extractNotInScopeName x + | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" + = Just $ NotInScopeTypeConstructorOrClass name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" + = Just $ NotInScopeThing name + | otherwise + = Nothing + +extractQualifiedModuleName :: T.Text -> Maybe T.Text +extractQualifiedModuleName x + | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" + = Just m + | otherwise + = Nothing + +-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules +-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier +-- from the imported one. +-- +-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s): +-- 1. +-- import qualified Data.Text as T +-- +-- Module ‘Data.Text’ does not export ‘putStrLn’. +-- +-- 2. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- +-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +-- +-- 3. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- import qualified Data.Function as T +-- +-- Neither ‘Data.Function’, +-- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +extractDoesNotExportModuleName :: T.Text -> Maybe T.Text +extractDoesNotExportModuleName x + | Just [m] <- +#if MIN_VERSION_ghc(9,4,0) + matchRegexUnifySpaces x "the module ‘([^’]*)’ does not export" + <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ export" +#else + matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" + <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" +#endif + = Just m + | otherwise + = Nothing +------------------------------------------------------------------------------------------------- + + +mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit +mkRenameEdit contents range name + | maybeIsInfixFunction == Just True = TextEdit range ("`" <> name <> "`") + | maybeIsTemplateFunction == Just True = TextEdit range ("'" <> name) + | otherwise = TextEdit range name + where + maybeIsInfixFunction = do + curr <- textInRange range <$> contents + pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr + maybeIsTemplateFunction = do + curr <- textInRange range <$> contents + pure $ "'" `T.isPrefixOf` curr + +extractRenamableTerms :: T.Text -> [T.Text] +extractRenamableTerms msg + -- Account for both "Variable not in scope" and "Not in scope" + | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg + | otherwise = [] + where + extractSuggestions = map getEnclosed + . concatMap singleSuggestions + . filter isKnownSymbol + . T.lines + singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited + isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t + getEnclosed = T.dropWhile (== '‘') + . T.dropWhileEnd (== '’') + . T.dropAround (\c -> c /= '‘' && c /= '’') + +-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace +-- between the end of the range and the next newline), extend the range to take up the whole line. +extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range +extendToWholeLineIfPossible contents range@Range{..} = + let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents + extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line + in if extend then Range _start (Position (_line _end + 1) 0) else range + +splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) +splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x + | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x + , (preCol, postCol) <- T.splitAt col mid + = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) + | otherwise = (x, T.empty) + +-- | Returns [start .. end[ +textInRange :: Range -> T.Text -> T.Text +textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = + case compare startRow endRow of + LT -> + let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine + (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of + [] -> ("", []) + firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) + maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines + in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) + EQ -> + let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) + in T.take (endCol - startCol) (T.drop startCol line) + GT -> "" + where + linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) + +-- | Returns the ranges for a binding in an import declaration +rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] +#if MIN_VERSION_ghc(9,5,0) +rangesForBindingImport ImportDecl{ + ideclImportList = Just (Exactly, L _ lies) + } b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies + where + b' = wrapOperatorInParens b +#else +rangesForBindingImport ImportDecl{ + ideclHiding = Just (False, L _ lies) + } b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies + where + b' = wrapOperatorInParens b +#endif +rangesForBindingImport _ _ = [] + +wrapOperatorInParens :: String -> String +wrapOperatorInParens x = + case uncons x of + -- see #2483 and #2859 + -- common lens functions use the _ prefix, and should not be wrapped in parens + Just ('_', _t) -> x + Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")" + Nothing -> mempty + +smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] +smallerRangesForBindingExport lies b = + concatMap (mapMaybe srcSpanToRange . ranges') lies + where + unqualify = snd . breakOnEnd "." + b' = wrapOperatorInParens . unqualify $ b + ranges' (L _ (IEThingWith _ thing _ inners)) + | T.unpack (printOutputable thing) == b' = [] + | otherwise = + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] + ranges' _ = [] + +rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] +rangesForBinding' b (L (locA -> l) (IEVar _ nm)) + | L _ (IEPattern _ (L _ b')) <- nm + , T.unpack (printOutputable b') == b + = [l] +rangesForBinding' b (L (locA -> l) x@IEVar{}) + | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) + | T.unpack (printOutputable thing) == b = [l] + | otherwise = + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] +rangesForBinding' _ _ = [] + +-- | 'allMatchRegex' combined with 'unifySpaces' +allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegexUnifySpaces message = + allMatchRegex (unifySpaces message) + +-- | Returns Just (all matches) for the first capture, or Nothing. +allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegex message regex = message =~~ regex + + +-- functions to help parse multiple import suggestions + +-- | Returns the first match if found +regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text +regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of + Just (h:_) -> Just h + _ -> Nothing + +-- | Process a list of (module_name, filename:src_span) values +-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] +regExImports :: T.Text -> Maybe [(T.Text, T.Text)] +regExImports msg + | Just mods' <- allMatchRegex msg "‘([^’]*)’" + , Just srcspans' <- allMatchRegex msg +#if MIN_VERSION_ghc(9,7,0) + "\\(at ([^)]*)\\)" +#else + "\\(([^)]*)\\)" +#endif + , mods <- [mod | [_,mod] <- mods'] + , srcspans <- [srcspan | [_,srcspan] <- srcspans'] + -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) + , let result = if length mods == length srcspans then + Just (zip mods srcspans) else Nothing + = result + | otherwise = Nothing + +matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) +matchRegExMultipleImports message = do +#if MIN_VERSION_ghc(9,7,0) + let pat = T.pack "Add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" +#else + let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" +#endif + (binding, imports) <- case matchRegexUnifySpaces message pat of + Just [x, xs] -> Just (x, xs) + _ -> Nothing + imps <- regExImports imports + return (binding, imps) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -0,0 +1,291 @@ +module Development.IDE.Plugin.CodeAction.Args + ( CodeActionTitle, + CodeActionPreferred, + GhcideCodeActionResult, + GhcideCodeAction, + mkGhcideCAPlugin, + mkGhcideCAsPlugin, + ToTextEdit (..), + ToCodeAction (..), + wrap, + mkCA, + ) +where + +import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Monad.Except (ExceptT (..), + runExceptT) +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Either (fromRight, + partitionEithers) +import Data.Functor ((<&>)) +import Data.IORef.Extra +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Development.IDE hiding + (pluginHandlers) +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.ExactPrint +import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, + rewriteToEdit) +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + GlobalBindingTypeSigsResult) +import Development.IDE.Spans.LocalBindings (Bindings) +import Development.IDE.Types.Exports (ExportsMap) +import Development.IDE.Types.Options (IdeOptions) +import Ide.Plugin.Error (PluginError) +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP + +type CodeActionTitle = T.Text + +type CodeActionPreferred = Bool + +type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] + +type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCodeActionResult + +------------------------------------------------------------------------------------------------- + +runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do + let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key + caaGhcSession <- onceIO $ runRule GhcSession + caaExportsMap <- + onceIO $ + caaGhcSession >>= \case + Just env -> do + pkgExports <- envPackageExports env + localExports <- readTVarIO (exportsMap $ shakeExtras state) + pure $ localExports <> pkgExports + _ -> pure mempty + caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions + caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments + caaContents <- + onceIO $ + runRule GetFileContents <&> \case + Just (_, txt) -> txt + Nothing -> Nothing + caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule + caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource + caaTmr <- onceIO $ runRule TypeCheck + caaHar <- onceIO $ runRule GetHieAst + caaBindings <- onceIO $ runRule GetBindings + caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + results <- liftIO $ + sequence + [ runReaderT (runExceptT codeAction) CodeActionArgs {..} + | caaDiagnostic <- diags + ] + let (_errs, successes) = partitionEithers results + pure $ concat successes + +mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) +mkCA title kind isPreferred diags edit = + InR $ CodeAction title kind (Just diags) isPreferred Nothing (Just edit) Nothing Nothing + +mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> T.Text -> PluginDescriptor IdeState +mkGhcideCAPlugin codeAction plId desc = + (defaultPluginDescriptor plId desc) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction $ + \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = diags}) -> do + results <- lift $ runGhcideCodeAction state params codeAction + pure $ + InL + [ mkCA title kind isPreferred diags edit + | (title, kind, isPreferred, tedit) <- results, + let edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing + ] + } + +mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> T.Text -> PluginDescriptor IdeState +mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions + +------------------------------------------------------------------------------------------------- + +class ToTextEdit a where + toTextEdit :: CodeActionArgs -> a -> IO [TextEdit] + +instance ToTextEdit TextEdit where + toTextEdit _ = pure . pure + +instance ToTextEdit Rewrite where + toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ + runMaybeT $ do + df <- MaybeT caaDf + let r = rewriteToEdit df rw + pure $ fromRight [] r + +instance ToTextEdit a => ToTextEdit [a] where + toTextEdit caa = foldMap (toTextEdit caa) + +instance ToTextEdit a => ToTextEdit (Maybe a) where + toTextEdit caa = maybe (pure []) (toTextEdit caa) + +instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where + toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) + +------------------------------------------------------------------------------------------------- + +data CodeActionArgs = CodeActionArgs + { caaExportsMap :: IO ExportsMap, + caaGhcSession :: IO (Maybe HscEnvEq), + caaIdeOptions :: IO IdeOptions, + caaParsedModule :: IO (Maybe ParsedModule), + caaContents :: IO (Maybe T.Text), + caaDf :: IO (Maybe DynFlags), + caaAnnSource :: IO (Maybe (Annotated ParsedSource)), + caaTmr :: IO (Maybe TcModuleResult), + caaHar :: IO (Maybe HieAstResult), + caaBindings :: IO (Maybe Bindings), + caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult), + caaDiagnostic :: Diagnostic + } + +-- | There's no concurrency in each provider, +-- so we don't need to be thread-safe here +onceIO :: MonadIO m => IO a -> m (IO a) +onceIO io = do + var <- liftIO $ newIORef Nothing + pure $ + readIORef var >>= \case + Just x -> pure x + _ -> io >>= \x -> writeIORef' var (Just x) >> pure x + +------------------------------------------------------------------------------------------------- + +wrap :: (ToCodeAction a) => a -> GhcideCodeAction +wrap = toCodeAction + +class ToCodeAction a where + toCodeAction :: a -> GhcideCodeAction + +instance ToCodeAction GhcideCodeAction where + toCodeAction = id + +instance Semigroup GhcideCodeAction where + a <> b = toCodeAction [a, b] + +instance Monoid GhcideCodeAction where + mempty = pure [] + +instance ToCodeAction a => ToCodeAction [a] where + toCodeAction = fmap concat . mapM toCodeAction + +instance ToCodeAction a => ToCodeAction (Maybe a) where + toCodeAction = maybe (pure []) toCodeAction + +instance ToCodeAction a => ToCodeAction (Either PluginError a) where + toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where + toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Nothing,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where + toCodeAction (title, kind, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Nothing,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where + toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Just isPreferred,) <$> toTextEdit caa te + +instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where + toCodeAction (title, kind, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te + +------------------------------------------------------------------------------------------------- + +toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction +toCodeAction1 get f = ExceptT . ReaderT $ \caa -> do + caaMay <- get caa + flip runReaderT caa . runExceptT . toCodeAction . f $ caaMay + +toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction +toCodeAction2 get f = ExceptT . ReaderT $ \caa -> + get caa >>= \case + Just x -> flip runReaderT caa . runExceptT . toCodeAction . f $ x + _ -> pure $ Right [] + +toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction +toCodeAction3 get f = ExceptT . ReaderT $ \caa -> get caa >>= flip runReaderT caa . runExceptT . toCodeAction . f + +-- | this instance returns a delta AST, useful for exactprint transforms +instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where +#if !MIN_VERSION_ghc(9,3,0) + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> + x >>= \case + Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s + _ -> pure $ Right [] +#else + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> + x >>= \case + Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . pm_parsed_source $ s + _ -> pure $ Right [] +#endif + +instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where + toCodeAction = toCodeAction3 caaExportsMap + +instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where + toCodeAction = toCodeAction3 caaIdeOptions + +instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x + +instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where + toCodeAction = toCodeAction1 caaParsedModule + +instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where + toCodeAction = toCodeAction2 caaParsedModule + +instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where + toCodeAction = toCodeAction1 caaContents + +instance ToCodeAction r => ToCodeAction (T.Text -> r) where + toCodeAction = toCodeAction2 caaContents + +instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where + toCodeAction = toCodeAction1 caaDf + +instance ToCodeAction r => ToCodeAction (DynFlags -> r) where + toCodeAction = toCodeAction2 caaDf + +instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where + toCodeAction = toCodeAction1 caaAnnSource + +instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where + toCodeAction = toCodeAction2 caaAnnSource + +instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where + toCodeAction = toCodeAction1 caaTmr + +instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where + toCodeAction = toCodeAction2 caaTmr + +instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where + toCodeAction = toCodeAction1 caaHar + +instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where + toCodeAction = toCodeAction2 caaHar + +instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where + toCodeAction = toCodeAction1 caaBindings + +instance ToCodeAction r => ToCodeAction (Bindings -> r) where + toCodeAction = toCodeAction2 caaBindings + +instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction1 caaGblSigs + +instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction2 caaGblSigs + +instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where + toCodeAction = toCodeAction1 caaGhcSession + +instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where + toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +module Development.IDE.Plugin.CodeAction.ExactPrint ( + Rewrite (..), + rewriteToEdit, + rewriteToWEdit, + + -- * Utilities + appendConstraint, + removeConstraint, + extendImport, + hideSymbol, + liftParseAST, + + wildCardSymbol +) where + +import Control.Monad +import Control.Monad.Trans +import Data.Char (isAlphaNum) +import Data.Data (Data) +import Data.Generics (listify) +import qualified Data.Text as T +import Development.IDE.GHC.Compat hiding (Annotation) +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.Util +import Development.IDE.Spans.Common +import GHC.Exts (IsList (fromList)) +import GHC.Stack (HasCallStack) +import Language.Haskell.GHC.ExactPrint +import Language.LSP.Protocol.Types + +import Development.IDE.Plugin.CodeAction.Util + +-- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. +import Control.Lens (_head, _last, over) +import Data.Bifunctor (first) +import Data.Default (Default (..)) +import Data.Maybe (fromJust, fromMaybe, + mapMaybe) +import GHC (AddEpAnn (..), + AnnContext (..), + AnnList (..), + AnnParen (..), + DeltaPos (SameLine), + EpAnn (..), + EpaLocation (EpaDelta), + IsUnicodeSyntax (NormalSyntax), + NameAdornment (NameParens), + TrailingAnn (AddCommaAnn), + addAnns, ann, + emptyComments, reAnnL) + + +------------------------------------------------------------------------------ + +-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the +-- given 'ast'. +data Rewrite where + Rewrite :: + (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) => + -- | The 'SrcSpan' that we want to rewrite + SrcSpan -> + -- | The ast that we want to graft + (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) -> + Rewrite + +------------------------------------------------------------------------------ +class ResetEntryDP ann where + resetEntryDP :: GenLocated ann ast -> GenLocated ann ast +instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where + -- resetEntryDP = flip setEntryDP (SameLine 0) + resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0) +instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where + resetEntryDP = id + +-- | Convert a 'Rewrite' into a list of '[TextEdit]'. +rewriteToEdit :: HasCallStack => + DynFlags -> + Rewrite -> + Either String [TextEdit] +rewriteToEdit dflags + (Rewrite dst f) = do + (ast, _ , _) <- runTransformT + $ do + ast <- f dflags + pure $ traceAst "REWRITE_result" $ resetEntryDP ast + let editMap = + [ TextEdit (fromJust $ srcSpanToRange dst) $ + T.pack $ exactPrint ast + ] + pure editMap + +-- | Convert a 'Rewrite' into a 'WorkspaceEdit' +rewriteToWEdit :: DynFlags + -> Uri + -> Rewrite + -> Either String WorkspaceEdit +rewriteToWEdit dflags uri + r = do + edits <- rewriteToEdit dflags + r + return $ + WorkspaceEdit + { _changes = Just (fromList [(uri, edits)]) + , _documentChanges = Nothing + , _changeAnnotations = Nothing + } + +------------------------------------------------------------------------------ + + +dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass) +dropHsParTy (L _ (HsParTy _ ty)) = ty +dropHsParTy other = other + +removeConstraint :: + -- | Predicate: Which context to drop. + (LHsType GhcPs -> Bool) -> + LHsType GhcPs -> + Rewrite +removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" + where + go :: LHsType GhcPs -> Rewrite +#if !MIN_VERSION_ghc(9,4,0) + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do +#else + go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do +#endif + let ctxt' = filter (not . toRemove) ctxt + removeStuff = (toRemove <$> headMaybe ctxt) == Just True + let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body + return $ case ctxt' of + [] -> hst_body' + _ -> do + let ctxt'' = over _last (first removeComma) ctxt' +#if MIN_VERSION_ghc(9,4,0) + L l $ it{ hst_ctxt = L l' ctxt'' +#else + L l $ it{ hst_ctxt = Just $ L l' ctxt'' +#endif + , hst_body = hst_body' + } + go (L _ (HsParTy _ ty)) = go ty + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other + +-- | Append a constraint at the end of a type context. +-- If no context is present, a new one will be created. +appendConstraint :: + -- | The new constraint to append + String -> + -- | The type signature where the constraint is to be inserted, also assuming annotated + LHsType GhcPs -> + Rewrite +appendConstraint constraintT = go . traceAst "appendConstraint" + where +#if MIN_VERSION_ghc(9,4,0) + go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do +#endif + constraint <- liftParseAST df constraintT + constraint <- pure $ setEntryDP constraint (SameLine 1) + let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' + -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint + -- we have to reposition it manually into the AnnContext + close_dp = case ctxt of + [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close + _ -> Nothing + ctxt' = over _last (first addComma) $ map dropHsParTy ctxt +#if MIN_VERSION_ghc(9,4,0) + return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]} +#else + return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]} +#endif + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L _ (HsParTy _ ty)) = go ty + go ast@(L l _) = Rewrite (locA l) $ \df -> do + -- there isn't a context, so we must create one + constraint <- liftParseAST df constraintT + lContext <- uniqueSrcSpanT + lTop <- uniqueSrcSpanT +#if MIN_VERSION_ghc(9,4,0) + let context = reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint] +#else + let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint] +#endif + annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens] + needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint + ast <- pure $ setEntryDP ast (SameLine 1) + + return $ reLocA $ L lTop $ HsQualTy noExtField context ast + +liftParseAST + :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) + => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) +liftParseAST df s = case parseAST df "" s of + Right x -> pure (makeDeltaAst x) + Left _ -> TransformT $ lift $ Left $ "No parse: " <> s + + +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (a : _) = Just a + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe other = Just $ last other + +------------------------------------------------------------------------------ +extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite +extendImport mparent identifier lDecl@(L l _) = + Rewrite (locA l) $ \df -> do + case mparent of + -- This will also work for `ImportAllConstructors` + -- Parsed source in GHC 9.4 uses absolute position annotation (RealSrcSpan), + -- while rewriting relies on relative positions. ghc-exactprint has the utility + -- makeDeltaAst for relativization. + Just parent -> extendImportViaParent df parent identifier (makeDeltaAst lDecl) + _ -> extendImportTopLevel identifier (makeDeltaAst lDecl) + +-- | Add an identifier or a data type to import list. Expects a Delta AST +-- +-- extendImportTopLevel "foo" AST: +-- +-- import A --> Error +-- import A (foo) --> Error +-- import A (bar) --> import A (bar, foo) +extendImportTopLevel :: + -- | rendered + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) +extendImportTopLevel thing (L l it@ImportDecl{..}) +#if MIN_VERSION_ghc(9,5,0) + | Just (hide, L l' lies) <- ideclImportList +#else + | Just (hide, L l' lies) <- ideclHiding +#endif + = do + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing + let alreadyImported = + printOutputable (occName (unLoc rdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies) + when alreadyImported $ + TransformT $ lift (Left $ thing <> " already imported") + + let lie = reLocA $ L src $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + rdr + x = reLocA $ L top $ IEVar +#if MIN_VERSION_ghc(9,8,0) + Nothing -- no deprecated +#else + noExtField +#endif + lie + + if x `elem` lies + then TransformT $ lift (Left $ thing <> " already imported") + else do + let lies' = addCommaInImportList lies x +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' lies')} +#else + return $ L l it{ideclHiding = Just (hide, L l' lies')} +#endif +extendImportTopLevel _ _ = TransformT $ lift $ Left "Unable to extend the import list" + +wildCardSymbol :: String +wildCardSymbol = ".." + +-- | Add an identifier with its parent to import list +-- +-- extendImportViaParent "Bar" "Cons" AST: +-- +-- import A --> Error +-- import A (Bar(..)) --> Error +-- import A (Bar(Cons)) --> Error +-- import A () --> import A (Bar(Cons)) +-- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) +-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) +-- +-- extendImportViaParent "Bar" ".." AST: +-- import A () --> import A (Bar(..)) +-- import A (Foo, Bar) -> import A (Foo, Bar(..)) +-- import A (Foo, Bar()) -> import A (Foo, Bar(..)) +extendImportViaParent :: + DynFlags -> + -- | parent (already parenthesized if needs) + String -> + -- | rendered child + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) +extendImportViaParent df parent child (L l it@ImportDecl{..}) +#if MIN_VERSION_ghc(9,5,0) + | Just (hide, L l' lies) <- ideclImportList = go hide l' [] lies +#else + | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies +#endif + where + go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) + | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports" + go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) + -- ThingAbs ie => ThingWith ie child + | parent == unIEWrappedName ie = do + srcChild <- uniqueSrcSpanT + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + childRdr + x :: LIE GhcPs = L ll' $ IEThingWith +#if MIN_VERSION_ghc(9,7,0) + (Nothing, addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) +#else + (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) +#endif + absIE NoIEWildcard [childLIE] + +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#else + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#endif + + go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs) + -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) + | parent == unIEWrappedName ie + , child == wildCardSymbol = do +#if MIN_VERSION_ghc(9,5,0) + let it' = it{ideclImportList = Just (hide, lies)} +#else + let it' = it{ideclHiding = Just (hide, lies)} +#endif + thing = IEThingWith newl twIE (IEWildcard 2) [] +#if MIN_VERSION_ghc(9,7,0) + newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' +#else + newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' +#endif + lies = L l' $ reverse pre ++ [L l'' thing] ++ xs + return $ L l it' + | parent == unIEWrappedName ie = do + let hasSibling = not $ null lies' + srcChild <- uniqueSrcSpanT + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 + let alreadyImported = + printOutputable (occName (unLoc childRdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies') + when alreadyImported $ + TransformT $ lift (Left $ child <> " already included in " <> parent <> " imports") + + let childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + childRdr +#if MIN_VERSION_ghc(9,5,0) + let it' = it{ideclImportList = Just (hide, lies)} +#else + let it' = it{ideclHiding = Just (hide, lies)} +#endif + lies = L l' $ reverse pre ++ + [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs + fixLast = if hasSibling then first addComma else id + return $ L l it' + go hide l' pre (x : xs) = go hide l' (x : pre) xs + go hide l' pre [] = do + -- [] => ThingWith parent [child] + l'' <- uniqueSrcSpanT + srcParent <- uniqueSrcSpanT + srcChild <- uniqueSrcSpanT + parentRdr <- liftParseAST df parent + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + isParentOperator = hasParen parent + let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (epl 0) parentRdr' + else IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + parentRdr' + parentRdr' = modifyAnns parentRdr $ \case + it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0} + other -> other + childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + childRdr +#if MIN_VERSION_ghc(9,7,0) + listAnn = (Nothing, epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]) +#else + listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] +#endif + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] + + lies' = addCommaInImportList (reverse pre) x +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' lies')} +#else + return $ L l it{ideclHiding = Just (hide, L l' lies')} +#endif +extendImportViaParent _ _ _ _ = TransformT $ lift $ Left "Unable to extend the import list via parent" + +-- Add an item in an import list, taking care of adding comma if needed. +addCommaInImportList :: + -- | Initial list + [LocatedAn AnnListItem a] + -- | Additional item + -> LocatedAn AnnListItem a + -> [LocatedAn AnnListItem a] +addCommaInImportList lies x = + fixLast lies ++ [newItem] + where + isTrailingAnnComma :: TrailingAnn -> Bool + isTrailingAnnComma (AddCommaAnn _) = True + isTrailingAnnComma _ = False + + -- check if there is an existing trailing comma + existingTrailingComma = fromMaybe False $ do + L lastItemSrcAnn _ <- lastMaybe lies + lastItemAnn <- case ann lastItemSrcAnn of + EpAnn _ lastItemAnn _ -> pure lastItemAnn + _ -> Nothing + pure $ any isTrailingAnnComma (lann_trailing lastItemAnn) + + hasSibling = not $ null lies + + -- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the + -- preceding item already has one. + newItem = first (if existingTrailingComma then addComma else id) $ + setEntryDP x (SameLine $ if hasSibling then 1 else 0) + + -- Add the comma (if needed) + fixLast :: [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a] + fixLast = over _last (first (if existingTrailingComma then id else addComma)) + +#if MIN_VERSION_ghc(9,5,0) +unIEWrappedName :: IEWrappedName GhcPs -> String +#else +unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String +#endif +unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ) + +hasParen :: String -> Bool +hasParen ('(' : _) = True +hasParen _ = False + + +------------------------------------------------------------------------------ + +-- | Hide a symbol from import declaration +hideSymbol :: + String -> LImportDecl GhcPs -> Rewrite +hideSymbol symbol lidecl@(L loc ImportDecl{..}) = +#if MIN_VERSION_ghc(9,5,0) + case ideclImportList of + Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing + Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) + Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports +#else + case ideclHiding of + Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing + Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) + Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports +#endif + +extendHiding :: + String -> + LImportDecl GhcPs -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +extendHiding symbol (L l idecls) mlies df = do + L l' lies <- case mlies of + Nothing -> do + src <- uniqueSrcSpanT + let ann = noAnnSrcSpanDP0 src + ann' = flip (fmap.fmap) ann $ \x -> x + {al_rest = [AddEpAnn AnnHiding (epl 1)] + ,al_open = Just $ AddEpAnn AnnOpenP (epl 1) + ,al_close = Just $ AddEpAnn AnnCloseP (epl 0) + } + return $ L ann' [] + Just pr -> pure pr + let hasSibling = not $ null lies + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + rdr <- liftParseAST df symbol + rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr) + let lie = reLocA $ L src $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + rdr + x = reLocA $ L top $ IEVar +#if MIN_VERSION_ghc(9,7,0) + Nothing +#else + noExtField +#endif + lie + x <- pure $ if hasSibling then first addComma x else x + lies <- pure $ over _head (`setEntryDP` SameLine 1) lies +#if MIN_VERSION_ghc(9,5,0) + return $ L l idecls{ideclImportList = Just (EverythingBut, L l' $ x : lies)} +#else + return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} +#endif + where + isOperator = not . all isAlphaNum . occNameString . rdrNameOcc + +deleteFromImport :: + String -> + LImportDecl GhcPs -> + XRec GhcPs [LIE GhcPs] -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do + let edited = L lieLoc deletedLies + lidecl' = + L l $ + idecl +#if MIN_VERSION_ghc(9,5,0) + { ideclImportList = Just (Exactly, edited) +#else + { ideclHiding = Just (False, edited) +#endif + } + pure lidecl' + where + deletedLies = + over _last removeTrailingComma $ + mapMaybe killLie lies + killLie :: LIE GhcPs -> Maybe (LIE GhcPs) + killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons)) + | nam == symbol = Nothing + | otherwise = + Just $ + L lieL $ + IEThingWith + xt + ty + wild + (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) + killLie v = Just v diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -0,0 +1,141 @@ +-- | Position indexed streams of characters +module Development.IDE.Plugin.CodeAction.PositionIndexed + ( PositionIndexed + , PositionIndexedString + , indexedByPosition + , indexedByPositionStartingFrom + , extendAllToIncludeCommaIfPossible + , extendToIncludePreviousNewlineIfPossible + , mergeRanges + ) +where + +import Data.Char +import Data.List +import Language.LSP.Protocol.Types (Position (Position), + Range (Range, _end, _start)) + +type PositionIndexed a = [(Position, a)] + +type PositionIndexedString = PositionIndexed Char + +-- | Add position indexing to a String. +-- +-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ +-- > [ ((0,0),'h') +-- > , ((0,1),'e') +-- > , ((0,2),'y') +-- > , ((0,3),'\n') +-- > , ((1,0),' ') +-- > , ((1,1),'h') +-- > , ((1,2),'o') +-- > ] +indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString +indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where + f (_, []) = Nothing + f (p@(Position l _), '\n' : rest) = + Just ((p, '\n'), (Position (l + 1) 0, rest)) + f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) + +-- | Add position indexing to a String. +-- +-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) +indexedByPosition :: String -> PositionIndexedString +indexedByPosition = indexedByPositionStartingFrom (Position 0 0) + +-- | Returns a tuple (before, contents, after) if the range is present. +-- The range is present only if both its start and end positions are present +unconsRange + :: Range + -> PositionIndexed a + -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) +unconsRange Range {..} indexedString + | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString + , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest + = Just (before, mid, after) + | otherwise + = Nothing + +-- | Strips out all the positions included in the range. +-- Returns 'Nothing' if the start or end of the range are not included in the input. +stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) +stripRange r s = case unconsRange r s of + Just (b, _, a) -> Just (b ++ a) + Nothing -> Nothing + +-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. +-- Assumes input ranges are sorted on the start positions. +mergeRanges :: [Range] -> [Range] +mergeRanges (r : r' : rest) + | + -- r' is contained in r + _end r > _end r' = mergeRanges (r : rest) + | + -- r and r' are overlapping + _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) + + | otherwise = r : mergeRanges (r' : rest) +mergeRanges other = other + +-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas +-- +-- @ +-- a, |b|, c ===> a|, b|, c +-- a, b, |c| ===> a, b|, c| +-- a, |b|, |c| ===> a|, b||, c| +-- @ +-- +-- If 'acceptNoComma' is enabled, additional ranges are returned +-- +-- @ +-- |a| ===> |a| +-- |a|, |b| ===> |a,| |b| +-- @ +extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] +extendAllToIncludeCommaIfPossible acceptNoComma indexedString = + mergeRanges . go indexedString . sortOn _start + where + go _ [] = [] + go input (r : rr) + | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r + , Just input' <- stripRange r' input + = r' : go input' rr + | otherwise + = go input rr + +extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] +extendToIncludeCommaIfPossible acceptNoComma indexedString range + | Just (before, _, after) <- unconsRange range indexedString + , after' <- dropWhile (isSpace . snd) after + , before' <- dropWhile (isSpace . snd) (reverse before) + = + -- a, |b|, c ===> a|, b|, c + [ range { _start = start' } | (start', ',') : _ <- [before'] ] + ++ + -- a, |b|, c ===> a, |b, |c + [ range { _end = end' } + | (_, ',') : rest <- [after'] + , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest + ] + ++ + ([range | acceptNoComma]) + | otherwise + = [range] + +extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range +extendToIncludePreviousNewlineIfPossible indexedString range + | Just (before, _, _) <- unconsRange range indexedString + , maybeFirstSpacePos <- lastSpacePos $ reverse before + = case maybeFirstSpacePos of + Nothing -> range + Just pos -> range { _start = pos } + | otherwise = range + where + lastSpacePos :: PositionIndexedString -> Maybe Position + lastSpacePos [] = Nothing + lastSpacePos ((pos, c):xs) = + if not $ isSpace c + then Nothing -- didn't find any space + else case xs of + (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) + _ -> Just pos diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -0,0 +1,21 @@ +module Development.IDE.Plugin.CodeAction.RuleTypes + (PackageExports(..) + ,IdentInfo(..) + ) where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Data.Typeable (Typeable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq) +import GHC.Generics (Generic) + +-- Rule type for caching Package Exports +type instance RuleResult PackageExports = ExportsMap + +newtype PackageExports = PackageExports HscEnvEq + deriving (Eq, Show, Typeable, Generic) + +instance Hashable PackageExports +instance NFData PackageExports diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs @@ -0,0 +1,45 @@ +module Development.IDE.Plugin.CodeAction.Util where + +import Data.Data (Data) +import Data.Time.Clock.POSIX (POSIXTime, + getCurrentTime, + utcTimeToPOSIXSeconds) +import qualified Data.Unique as U +import Debug.Trace +import Development.IDE.GHC.Compat.ExactPrint as GHC +import Development.IDE.GHC.Dump (showAstDataHtml) +import GHC.Stack +import GHC.Utils.Outputable +import System.Environment.Blank (getEnvDefault) +import System.IO.Unsafe +import Text.Printf +-------------------------------------------------------------------------------- +-- Tracing exactprint terms + +-- Should in `Development.IDE.GHC.Orphans`, +-- leave it here to prevent cyclic module dependency + +{-# NOINLINE timestamp #-} +timestamp :: POSIXTime +timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime + +debugAST :: Bool +debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" + +-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection +traceAst :: (Data a, ExactPrint a, HasCallStack) => String -> a -> a +traceAst lbl x + | debugAST = trace doTrace x + | otherwise = x + where + renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} + htmlDump = showAstDataHtml x + doTrace = unsafePerformIO $ do + u <- U.newUnique + let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) + writeFile htmlDumpFileName $ renderDump htmlDump + return $ unlines + [prettyCallStack callStack ++ ":" + , exactPrint x + , "file://" ++ htmlDumpFileName] + diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Plugin.Plugins.AddArgument (plugin) where + +import Control.Monad (join) +import Control.Monad.Trans.Class (lift) +import Data.Bifunctor (Bifunctor (..)) +import Data.Either.Extra (maybeToEither) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint (exactPrint, + makeDeltaAst) +import Development.IDE.GHC.Error (spanContainsRange) +import Development.IDE.GHC.ExactPrint (genAnchor1, + modifyMgMatchesT', + modifySigWithM, + modifySmallestDeclWithM) +import Development.IDE.Plugin.Plugins.Diagnostic +import GHC (EpAnn (..), + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + SrcSpanAnnN, + emptyComments, + noAnn) +import GHC.Types.SrcLoc (generatedSrcSpan) +import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.PluginUtils (makeDiffTextEdit) +import Language.Haskell.GHC.ExactPrint (TransformT (..), + noAnnSrcSpanDP1, + runTransformT) +import Language.LSP.Protocol.Types + +#if !MIN_VERSION_ghc(9,4,0) +import GHC (TrailingAnn (..)) +import GHC.Hs (IsUnicodeSyntax (..)) +import Language.Haskell.GHC.ExactPrint.Transform (d1) +#endif + +#if MIN_VERSION_ghc(9,4,0) +import Development.IDE.GHC.ExactPrint (epl) +import GHC.Parser.Annotation (TokenLocation (..)) +#endif + +-- When GHC tells us that a variable is not bound, it will tell us either: +-- - there is an unbound variable with a given type +-- - there is an unbound variable (GHC provides no type suggestion) +-- +-- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the +-- last position of each LHS of the top-level bindings for this HsDecl). +-- +-- NOTE When adding a new argument to a declaration, the corresponding argument's type in declaration's signature might +-- not be the last type in the signature, such as: +-- foo :: a -> b -> c -> d +-- foo a b = \c -> ... +-- In this case a new argument would have to add its type between b and c in the signature. +plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])] +plugin parsedModule Diagnostic {_message, _range} + | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ + | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ) + | otherwise = pure [] + where + message = unifySpaces _message + +-- Given a name for the new binding, add a new pattern to the match in the last position, +-- returning how many patterns there were in this match prior to the transformation: +-- addArgToMatch "foo" `bar arg1 arg2 = ...` +-- => (`bar arg1 arg2 foo = ...`, 2) +addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int) +addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = + let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name + newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) + in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), Prelude.length pats) + +-- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind. +-- Also return: +-- - the declaration's name +-- - the number of bound patterns in the declaration's matches prior to the transformation +-- +-- For example: +-- insertArg "new_pat" `foo bar baz = 1` +-- => (`foo bar baz new_pat = 1`, Just ("foo", 2)) +appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int)) +appendFinalPatToMatches name = \case + (L locDecl (ValD xVal fun@FunBind{fun_matches=mg,fun_id = idFunBind})) -> do + (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats + numPats <- TransformT $ lift $ maybeToEither (PluginInternalError "Unexpected empty match group in HsDecl") numPatsMay + let decl' = L locDecl (ValD xVal fun{fun_matches=mg'}) + pure (decl', Just (idFunBind, numPats)) + decl -> pure (decl, Nothing) + where + combineMatchNumPats Nothing other = pure other + combineMatchNumPats other Nothing = pure other + combineMatchNumPats (Just l) (Just r) + | l == r = pure (Just l) + | otherwise = Left $ PluginInternalError "Unexpected different numbers of patterns in HsDecl MatchGroup" + +-- The add argument works as follows: +-- 1. Attempt to add the given name as the last pattern of the declaration that contains `range`. +-- 2. If such a declaration exists, use that declaration's name to modify the signature of said declaration, if it +-- has a type signature. +-- +-- NOTE For the following situation, the type signature is not updated (it's unclear what should happen): +-- type FunctionTySyn = () -> Int +-- foo :: FunctionTySyn +-- foo () = new_def +-- +-- TODO instead of inserting a typed hole; use GHC's suggested type from the error +addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] +addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do + (newSource, _, _) <- runTransformT $ do + (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc) + case matchedDeclNameMay of + Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' + Nothing -> pure moduleSrc' + let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource) + pure [("Add argument ‘" <> name <> "’ to function", diff)] + where + addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg + addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name + + spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range) + +-- Transform an LHsType into a list of arguments and return type, to make transformations easier. +hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) +hsTypeToFunTypeAsList = \case + L spanAnnA (HsFunTy xFunTy arrow lhs rhs) -> + let (rhsArgs, rhsRes) = hsTypeToFunTypeAsList rhs + in ((spanAnnA, xFunTy, arrow, lhs):rhsArgs, rhsRes) + ty -> ([], ty) + +-- The inverse of `hsTypeToFunTypeAsList` +hsTypeFromFunTypeAsList :: ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) -> LHsType GhcPs +hsTypeFromFunTypeAsList (args, res) = + foldr (\(spanAnnA, xFunTy, arrow, argTy) res -> L spanAnnA $ HsFunTy xFunTy arrow argTy res) res args + +-- Add a typed hole to a type signature in the given argument position: +-- 0 `foo :: ()` => foo :: _ -> () +-- 2 `foo :: FunctionTySyn` => foo :: FunctionTySyn +-- 1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int +addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs) +addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = + let (args, res) = hsTypeToFunTypeAsList lsigTy +#if MIN_VERSION_ghc(9,4,0) + wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem []) emptyComments) generatedSrcSpan + arrowAnn = TokenLoc (epl 1) + newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow (L arrowAnn HsNormalTok), L wildCardAnn $ HsWildCardTy noExtField) +#else + wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan + newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField) +#endif + -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments + -- in the signature, then we return the original type signature. + -- This situation most likely occurs due to a function type synonym in the signature + insertArg n _ | n < 0 = error "Not possible" + insertArg 0 as = newArg:as + insertArg _ [] = [] + insertArg n (a:as) = a : insertArg (n - 1) as + lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res) + in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy') + diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs @@ -0,0 +1,56 @@ +module Development.IDE.Plugin.Plugins.Diagnostic ( + matchVariableNotInScope, + matchRegexUnifySpaces, + unifySpaces, + matchFoundHole, + matchFoundHoleIncludeUnderscore, + ) + where + +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Text as T +import Text.Regex.TDFA ((=~~)) + +unifySpaces :: T.Text -> T.Text +unifySpaces = T.unwords . T.words + +-- | Returns Just (the submatches) for the first capture, or Nothing. +matchRegex :: T.Text -> T.Text -> Maybe [T.Text] +matchRegex message regex = case message =~~ regex of + Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings + Nothing -> Nothing + +-- | 'matchRegex' combined with 'unifySpaces' +matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] +matchRegexUnifySpaces message = matchRegex (unifySpaces message) + +matchFoundHole :: T.Text -> Maybe (T.Text, T.Text) +matchFoundHole message + | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" = + Just (name, typ) + | otherwise = Nothing + +matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text) +matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message + +matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text) +matchVariableNotInScope message + -- * Variable not in scope: + -- suggestAcion :: Maybe T.Text -> Range -> Range + -- * Variable not in scope: + -- suggestAcion + | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ) + | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing) + | otherwise = Nothing + where + matchVariableNotInScopeTyped message + | Just [name, typ0] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" + , -- When some name in scope is similar to not-in-scope variable, the type is followed by + -- "Suggested fix: Perhaps use ..." + typ:_ <- T.splitOn " Suggested fix:" typ0 = + Just (name, typ) + | otherwise = Nothing + matchVariableNotInScopeUntyped message + | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" = + Just name + | otherwise = Nothing diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -0,0 +1,104 @@ +module Development.IDE.Plugin.Plugins.FillHole + ( suggestFillHole + ) where + +import Control.Monad (guard) +import Data.Char +import qualified Data.Text as T +import Development.IDE.Plugin.Plugins.Diagnostic +import Language.LSP.Protocol.Types (Diagnostic (..), + TextEdit (TextEdit)) +import Text.Regex.TDFA (MatchResult (..), + (=~)) + +suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillHole Diagnostic{_range=_range,..} + | Just holeName <- extractHoleName _message + , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = + let isInfixHole = _message =~ addBackticks holeName :: Bool in + map (proposeHoleFit holeName False isInfixHole) holeFits + ++ map (proposeHoleFit holeName True isInfixHole) refFits + | otherwise = [] + where + extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + addBackticks text = "`" <> text <> "`" + addParens text = "(" <> text <> ")" + proposeHoleFit holeName parenthise isInfixHole name = + case T.uncons name of + Nothing -> error "impossible: empty name provided by ghc" + Just (firstChr, _) -> + let isInfixOperator = firstChr == '(' + name' = getOperatorNotation isInfixHole isInfixOperator name in + ( "replace " <> holeName <> " with " <> name + , TextEdit _range (if parenthise then addParens name' else name') + ) + getOperatorNotation True False name = addBackticks name + getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) + getOperatorNotation _isInfixHole _isInfixOperator name = name + headOrThrow msg = \case + [] -> error msg + (x:_) -> x + +processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) +processHoleSuggestions mm = (holeSuggestions, refSuggestions) +{- + • Found hole: _ :: LSP.Handlers + + Valid hole fits include def + Valid refinement hole fits include + fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) + fromJust (_ :: Maybe LSP.Handlers) + haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams + LSP.Handlers) + T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) + T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) +-} + where + t = id @T.Text + holeSuggestions = do + -- get the text indented under Valid hole fits + validHolesSection <- + getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm + -- the Valid hole fits line can contain a hole fit + holeFitLine <- + mapHead + (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) + validHolesSection + let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine + guard (not $ T.null holeFit) + return holeFit + refSuggestions = do -- @[] + -- get the text indented under Valid refinement hole fits + refinementSection <- + getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm + case refinementSection of + [] -> error "GHC provided invalid hole fit options" + (_:refinementSection) -> do + -- get the text for each hole fit + holeFitLines <- getIndentedGroups refinementSection + let holeFit = T.strip $ T.unwords holeFitLines + guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" + return holeFit + + mapHead f (a:aa) = f a : aa + mapHead _ [] = [] + +-- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] +getIndentedGroups :: [T.Text] -> [[T.Text]] +getIndentedGroups [] = [] +getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll +-- | +-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] +getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] +getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of + (l:ll) -> case span (\l' -> indentation l < indentation l') ll of + (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest + _ -> [] + +indentation :: T.Text -> Int +indentation = T.length . T.takeWhile isSpace + diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs @@ -0,0 +1,79 @@ +module Development.IDE.Plugin.Plugins.FillTypeWildcard + ( suggestFillTypeWildcard + ) where + +import Data.Char +import qualified Data.Text as T +import Language.LSP.Protocol.Types (Diagnostic (..), + TextEdit (TextEdit)) + +suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillTypeWildcard Diagnostic{_range=_range,..} +-- Foo.hs:3:8: error: +-- * Found type wildcard `_' standing for `p -> p1 -> p' + | "Found type wildcard" `T.isInfixOf` _message + , " standing for " `T.isInfixOf` _message + , typeSignature <- extractWildCardTypeSignature _message + = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] + | otherwise = [] + +-- | Extract the type and surround it in parentheses except in obviously safe cases. +-- +-- Inferring when parentheses are actually needed around the type signature would +-- require understanding both the precedence of the context of the hole and of +-- the signature itself. Inserting them (almost) unconditionally is ugly but safe. +extractWildCardTypeSignature :: T.Text -> T.Text +extractWildCardTypeSignature msg + | enclosed || not isApp || isToplevelSig = sig + | otherwise = "(" <> sig <> ")" + where + msgSigPart = snd $ T.breakOnEnd "standing for " msg + (sig, rest) = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart + -- If we're completing something like ‘foo :: _’ parens can be safely omitted. + isToplevelSig = errorMessageRefersToToplevelHole rest + -- Parenthesize type applications, e.g. (Maybe Char). + isApp = T.any isSpace sig + -- Do not add extra parentheses to lists, tuples and already parenthesized types. + enclosed = + case T.uncons sig of + Nothing -> error "GHC provided invalid type" + Just (firstChr, _) -> not (T.null sig) && (firstChr, T.last sig) `elem` [('(', ')'), ('[', ']')] + +-- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@. +-- The former is considered toplevel case for which the function returns 'True', +-- the latter is not toplevel and the returned value is 'False'. +-- +-- When type hole is at toplevel then there’s a line starting with +-- "• In the type signature" which ends with " :: _" like in the +-- following snippet: +-- +-- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error: +-- • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’ +-- To use the inferred type, enable PartialTypeSignatures +-- • In the type signature: decl :: _ +-- In an equation for ‘splitAnnots’: +-- splitAnnots m@HsModule {hsmodAnn, hsmodDecls} +-- = undefined +-- where +-- ann :: SrcSpanAnnA +-- decl :: _ +-- L ann decl = head hsmodDecls +-- • Relevant bindings include +-- [REDACTED] +-- +-- When type hole is not at toplevel there’s a stack of where +-- the hole was located ending with "In the type signature": +-- +-- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error: +-- • Found type wildcard ‘_’ standing for ‘GhcPs’ +-- To use the inferred type, enable PartialTypeSignatures +-- • In the first argument of ‘HsDecl’, namely ‘_’ +-- In the type ‘HsDecl _’ +-- In the type signature: decl :: HsDecl _ +-- • Relevant bindings include +-- [REDACTED] +errorMessageRefersToToplevelHole :: T.Text -> Bool +errorMessageRefersToToplevelHole msg = + not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest + where + (prefix, rest) = T.breakOn "• In the type signature:" msg diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs @@ -0,0 +1,98 @@ +module Development.IDE.Plugin.Plugins.ImportUtils + ( ImportStyle(..), + quickFixImportKind', + quickFixImportKind, + renderImportStyle, + unImportStyle, + importStyles, + QualifiedImportStyle(..), + qualifiedImportStyle + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol) +import Development.IDE.Types.Exports +import Language.LSP.Protocol.Types (CodeActionKind (..)) + +-- | Possible import styles for an 'IdentInfo'. +-- +-- The first 'Text' parameter corresponds to the 'rendered' field of the +-- 'IdentInfo'. +data ImportStyle + = ImportTopLevel T.Text + -- ^ Import a top-level export from a module, e.g., a function, a type, a + -- class. + -- + -- > import M (?) + -- + -- Some exports that have a parent, like a type-class method or an + -- associated type/data family, can still be imported as a top-level + -- import. + -- + -- Note that this is not the case for constructors, they must always be + -- imported as part of their parent data type. + + | ImportViaParent T.Text T.Text + -- ^ Import an export (first parameter) through its parent (second + -- parameter). + -- + -- import M (P(?)) + -- + -- @P@ and @?@ can be a data type and a constructor, a class and a method, + -- a class and an associated type/data family, etc. + + | ImportAllConstructors T.Text + -- ^ Import all constructors for a specific data type. + -- + -- import M (P(..)) + -- + -- @P@ can be a data type or a class. + deriving Show + +importStyles :: IdentInfo -> NonEmpty ImportStyle +importStyles i@(IdentInfo {parent}) + | Just p <- pr + -- Constructors always have to be imported via their parent data type, but + -- methods and associated type/data families can also be imported as + -- top-level exports. + = ImportViaParent rend p + :| [ImportTopLevel rend | not (isDatacon i)] + <> [ImportAllConstructors p] + | otherwise + = ImportTopLevel rend :| [] + where rend = rendered i + pr = occNameText <$> parent + +-- | Used for adding new imports +renderImportStyle :: ImportStyle -> T.Text +renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" +renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" +renderImportStyle (ImportAllConstructors p) = p <> "(..)" + +-- | Used for extending import lists +unImportStyle :: ImportStyle -> (Maybe String, String) +unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) +unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) +unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) + + +quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind +quickFixImportKind' x (ImportTopLevel _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.topLevel" +quickFixImportKind' x (ImportViaParent _ _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.withParent" +quickFixImportKind' x (ImportAllConstructors _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.allConstructors" + +quickFixImportKind :: T.Text -> CodeActionKind +quickFixImportKind x = CodeActionKind_Custom $ "quickfix.import." <> x + +-- | Possible import styles for qualified imports +data QualifiedImportStyle = QualifiedImportPostfix | QualifiedImportPrefix + deriving Show + +qualifiedImportStyle :: DynFlags -> QualifiedImportStyle +qualifiedImportStyle df | hasImportQualifedPostEnabled && hasPrePositiveQualifiedWarning = QualifiedImportPostfix + | otherwise = QualifiedImportPrefix + where hasImportQualifedPostEnabled = xopt ImportQualifiedPost df + hasPrePositiveQualifiedWarning = wopt Opt_WarnPrepositiveQualifiedModule df diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -0,0 +1,3755 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- don't warn about usage HasCallStack + +module Main + ( main + ) where + +import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Test +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokensEdit (_start), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Text.Regex.TDFA ((=~)) + + +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) +import Test.Hls + +import qualified Development.IDE.Plugin.CodeAction as Refactor +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Test.AddArgument + +main :: IO () +main = defaultTestRunner tests + +refactorPlugin :: IO (IdePlugins IdeState) +refactorPlugin = do + exactprintLog <- pluginTestRecorder + ghcideLog <- pluginTestRecorder + pure $ IdePlugins $ + [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports" + , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures" + , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings" + , Refactor.fillHolePluginDescriptor exactprintLog "ghcide-code-actions-fill-holes" + , Refactor.extendImportPluginDescriptor exactprintLog "ghcide-completions-1" + ] ++ GhcIde.descriptors ghcideLog + +tests :: TestTree +tests = + testGroup "refactor" + [ initializeTests + , codeActionTests + , codeActionHelperFunctionTests + , completionTests + ] + +initializeTests :: TestTree +initializeTests = withResource acquire release tests + where + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = testGroup "initialize response capabilities" + [ chk " code action" _codeActionProvider (Just (InR (CodeActionOptions {_workDoneProgress = Just False, _codeActionKinds = Nothing, _resolveProvider = Just False}))) + , che " execute command" _executeCommandProvider [extendImportCommandId] + ] + where + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + -- Check if expected exists in commands. Note that commands can arrive in different order. + mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = run initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + +completionTests :: TestTree +completionTests = + testGroup "auto import snippets" + [ completionCommandTest + "show imports not in list - simple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum)", "f = joi"] + (Position 3 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - multi-line" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum)", "f = joi"] + (Position 4 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - names with _" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] + (Position 3 11) + "mapM_" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] + , completionCommandTest + "show imports not in list - initial empty list" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , testGroup "qualified imports" + [ completionCommandTest + "single" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] + (Position 3 22) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] + , completionCommandTest + "as" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , completionCommandTest + "multiple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] + (Position 4 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] + -- Regression test for https://github.com/haskell/haskell-language-server/issues/2824 + , completionNoCommandTest + "explicit qualified" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import qualified Control.Monad as M (j)"] + (Position 2 38) + "join" + , completionNoCommandTest + "explicit qualified post" + ["{-# LANGUAGE NoImplicitPrelude, ImportQualifiedPost #-}", + "module A where", "import Control.Monad qualified as M (j)"] + (Position 2 38) + "join" + , completionNoCommandTest + "multiline import" + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "module A where", "import Control.Monad", " (fore)"] + (Position 3 9) + "forever" + ] + , testGroup "Data constructor" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionCommandTest + "parent imported abs" + ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionNoCommandTest + "parent imported all" + ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "function from Prelude" + ["module A where", "import Data.Maybe ()", "Nothing"] + (Position 2 4) + "Nothing" + , completionCommandTest + "type operator parent" + ["module A where", "import Data.Type.Equality ()", "f = Ref"] + (Position 2 8) + "Refl" + ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] + ] + , testGroup "Record completion" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "FormatParse"] + (Position 2 10) + "FormatParse" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + , completionCommandTest + "parent imported" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + (Position 2 10) + "FormatParse" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + (Position 2 10) + "FormatParse" + ] + , testGroup "Package completion" + [ completionCommandTest + "import Data.Sequence" + ["module A where", "foo :: Seq"] + (Position 1 9) + "Seq" + ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] + + , completionCommandTest + "qualified import" + ["module A where", "foo :: Seq.Seq"] + (Position 1 13) + "Seq" + ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] + ] + ] + +completionCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> [T.Text] -> TestTree +completionCommandTest name src pos wanted expected = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- skipManyTill anyMessage (getCompletions docId pos) + let wantedC = mapMaybe (\case + CompletionItem {_insertText = Just x, _command = Just cmd} + | wanted `T.isPrefixOf` x -> Just cmd + _ -> Nothing + ) compls + case wantedC of + [] -> + liftIO $ assertFailure $ "Cannot find completion " <> show wanted <> " in: " <> show [_label | CompletionItem {_label} <- compls] + command:_ -> do + executeCommand command + if src /= expected + then do + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) + liftIO $ modifiedCode @?= T.unlines expected + else do + expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit -> + liftIO $ assertFailure $ "Expected no edit but got: " <> show edit + +completionNoCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> TestTree +completionNoCommandTest name src pos wanted = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let isPrefixOfInsertOrLabel ci = any (wanted `T.isPrefixOf`) [fromMaybe "" (ci ^. L.insertText), ci ^. L.label] + case find isPrefixOfInsertOrLabel compls of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command + + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ suggestImportDisambiguationTests + , insertImportTests + , extendImportTests + , renameActionTests + , typeWildCardActionTests + , removeImportTests + , suggestImportClassMethodTests + , suggestImportTests + , suggestAddRecordFieldImportTests + , suggestHideShadowTests + , fixConstructorImportTests + , fixModuleImportTypoTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + , deleteUnusedDefinitionTests + , addInstanceConstraintTests + , addFunctionConstraintTests + , removeRedundantConstraintsTests + , addTypeAnnotationsToLiteralsTest + , exportUnusedTests + , addImplicitParamsConstraintTests + , removeExportTests + , Test.AddArgument.tests + ] + +insertImportTests :: TestTree +insertImportTests = testGroup "insert import" + [ checkImport + "module where keyword lower in file no exports" + "WhereKeywordLowerInFileNoExports.hs" + "WhereKeywordLowerInFileNoExports.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with exports" + "WhereDeclLowerInFile.hs" + "WhereDeclLowerInFile.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with comments before it" + "WhereDeclLowerInFileWithCommentsBeforeIt.hs" + "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" + "import Data.Int" + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for " + ++ "case when shebang is not placed at top of file") + (checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" + (checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid") + , checkImport + "pragmas not at top with module declaration" + "PragmaNotAtTopWithModuleDecl.hs" + "PragmaNotAtTopWithModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "pragmas not at top with imports" + "PragmaNotAtTopWithImports.hs" + "PragmaNotAtTopWithImports.expected.hs" + "import Data.Monoid" + , checkImport + "above comment at top of module" + "CommentAtTop.hs" + "CommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multiple comments below" + "CommentAtTopMultipleComments.hs" + "CommentAtTopMultipleComments.expected.hs" + "import Data.Monoid" + , checkImport + "above curly brace comment" + "CommentCurlyBraceAtTop.hs" + "CommentCurlyBraceAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multi-line comment" + "MultiLineCommentAtTop.hs" + "MultiLineCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no module explicit exports" + "NoExplicitExportCommentAtTop.hs" + "NoExplicitExportCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above two-dash comment with no pipe" + "TwoDashOnlyComment.hs" + "TwoDashOnlyComment.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no (module .. where) decl" + "NoModuleDeclarationCommentAtTop.hs" + "NoModuleDeclarationCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top with no (module .. where) decl" + "NoModuleDeclaration.hs" + "NoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (data dec is)" + "DataAtTop.hs" + "DataAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (newtype is)" + "NewTypeAtTop.hs" + "NewTypeAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with no explicit module exports" + "NoExplicitExports.hs" + "NoExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "add to correctly placed existing import" + "ImportAtTop.hs" + "ImportAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "add to multiple correctly placed existing imports" + "MultipleImportsAtTop.hs" + "MultipleImportsAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top of module" + "LangPragmaModuleAtTop.hs" + "LangPragmaModuleAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma and explicit module exports" + "LangPragmaModuleWithComment.hs" + "LangPragmaModuleWithComment.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top and no module declaration" + "LanguagePragmaAtTop.hs" + "LanguagePragmaAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with multiple lang pragmas and no module declaration" + "MultipleLanguagePragmasNoModuleDeclaration.hs" + "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs" + "LanguagePragmasThenShebangs.hs" + "LanguagePragmasThenShebangs.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs but no comment at top" + "PragmasAndShebangsNoComment.hs" + "PragmasAndShebangsNoComment.expected.hs" + "import Data.Monoid" + , checkImport + "module decl no exports under pragmas and shebangs" + "PragmasShebangsAndModuleDecl.hs" + "PragmasShebangsAndModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "module decl with explicit import under pragmas and shebangs" + "PragmasShebangsModuleExplicitExports.hs" + "PragmasShebangsModuleExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "module decl and multiple imports" + "ModuleDeclAndImports.hs" + "ModuleDeclAndImports.expected.hs" + "import Data.Monoid" + , importQualifiedTests + ] + +importQualifiedTests :: TestTree +importQualifiedTests = testGroup "import qualified prefix suggestions" + [ checkImport' + "qualified import works with 3.8 code action kinds" + "ImportQualified.hs" + "ImportQualified.expected.hs" + "import qualified Control.Monad as Control" + ["import Control.Monad (when)"] + , checkImport' + "qualified import in postfix position works with 3.8 code action kinds" + "ImportPostQualified.hs" + "ImportPostQualified.expected.hs" + "import Control.Monad qualified as Control" + ["import qualified Control.Monad as Control", "import Control.Monad (when)"] + ] + +checkImport :: TestName -> FilePath -> FilePath -> T.Text -> TestTree +checkImport testName originalPath expectedPath action = + checkImport' testName originalPath expectedPath action [] + +checkImport' :: TestName -> FilePath -> FilePath -> T.Text -> [T.Text] -> TestTree +checkImport' testName originalPath expectedPath action excludedActions = + testSessionWithExtraFiles "import-placement" testName $ \dir -> + check (dir originalPath) (dir expectedPath) action + where + check :: FilePath -> FilePath -> T.Text -> Session () + check originalPath expectedPath action = do + oSrc <- liftIO $ readFileUtf8 originalPath + shouldBeDocContents <- liftIO $ readFileUtf8 expectedPath + originalDoc <- createDoc originalPath "haskell" oSrc + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions originalDoc + for_ excludedActions (\a -> assertNoActionWithTitle a actionsOrCommands) + chosenAction <- pickActionWithTitle action actionsOrCommands + executeCodeAction chosenAction + originalDocAfterAction <- documentContents originalDoc + liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction + +renameActionTests :: TestTree +renameActionTests = testGroup "rename actions" + [ check "change to local variable name" + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argNme" + ] + ("Replace with ‘argName’", R 2 14 2 20) + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argName" + ] + , check "change to name of imported function" + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybToList" + ] + ("Replace with ‘maybeToList’", R 3 6 3 16) + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybeToList" + ] + , check "change infix function" + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monnus` y" + ] + ("Replace with ‘monus’", R 3 12 3 20) + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monus` y" + ] + , check "change template function" + [ "{-# LANGUAGE TemplateHaskellQuotes #-}" + , "module Testing where" + , "import Language.Haskell.TH (Name)" + , "foo :: Name" + , "foo = 'bread" + ] + ("Replace with ‘break’", R 4 6 4 12) + [ "{-# LANGUAGE TemplateHaskellQuotes #-}" + , "module Testing where" + , "import Language.Haskell.TH (Name)" + , "foo :: Name" + , "foo = 'break" + ] + , testSession "suggest multiple local variable names" $ do + doc <- createDoc "Testing.hs" "haskell" $ T.unlines + [ "module Testing where" + , "foo :: Char -> Char -> Char -> Char" + , "foo argument1 argument2 argument3 = argumentX" + ] + _ <- waitForDiagnostics + actions <- getCodeActions doc (R 2 36 2 45) + traverse_ (assertActionWithTitle actions) + [ "Replace with ‘argument1’" + , "Replace with ‘argument2’" + , "Replace with ‘argument3’" + ] + ] + where + check :: TestName -> [T.Text] -> (T.Text, Range) -> [T.Text] -> TestTree + check testName linesOrig (actionTitle, actionRange) linesExpected = + testSession testName $ do + let contentBefore = T.unlines linesOrig + doc <- createDoc "Testing.hs" "haskell" contentBefore + _ <- waitForDiagnostics + action <- pickActionWithTitle actionTitle =<< getCodeActions doc actionRange + executeCodeAction action + contentAfter <- documentContents doc + let expectedContent = T.unlines linesExpected + liftIO $ expectedContent @=? contentAfter + +typeWildCardActionTests :: TestTree +typeWildCardActionTests = testGroup "type wildcard actions" + [ testUseTypeSignature "global signature" + [ "func :: _" + , "func x = x" + ] + [ "func :: p -> p" + , "func x = x" + ] + , testUseTypeSignature "local signature" + [ "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + [ "func :: Int -> Int" + , "func x =" + , " let y :: Int" + , " y = x * 2" + , " in y" + ] + , testUseTypeSignature "multi-line message 1" + [ "func :: _" + , "func x y = x + y" + ] + [ if ghcVersion >= GHC98 + then "func :: a -> a -> a" -- 9.8 has a different suggestion + else "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "type in parentheses" + [ "func :: a -> _" + , "func x = (x, const x)" + ] + [ "func :: a -> (a, b -> a)" + , "func x = (x, const x)" + ] + , testUseTypeSignature "type in brackets" + [ "func :: _ -> Maybe a" + , "func xs = head xs" + ] + [ "func :: [Maybe a] -> Maybe a" + , "func xs = head xs" + ] + , testUseTypeSignature "unit type" + [ "func :: IO _" + , "func = putChar 'H'" + ] + [ "func :: IO ()" + , "func = putChar 'H'" + ] + , testUseTypeSignature "no spaces around '::'" + [ "func::_" + , "func x y = x + y" + ] + [ if ghcVersion >= GHC98 + then "func::a -> a -> a" -- 9.8 has a different suggestion + else "func::Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testGroup "add parens if hole is part of bigger type" + [ testUseTypeSignature "subtype 1" + [ "func :: _ -> Integer -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 2" + [ "func :: Integer -> _ -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 3" + [ "func :: Integer -> Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 4" + [ "func :: Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> (Integer -> Integer)" + , "func x y = x + y" + ] + ] + ] + where + -- | Test session of given name, checking action "Use type signature..." + -- on a test file with given content and comparing to expected result. + testUseTypeSignature name textIn textOut = testSession name $ do + let fileStart = "module Testing where" + content = T.unlines $ fileStart : textIn + expectedContentAfterAction = T.unlines $ fileStart : textOut + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + [addSignature] <- pure [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isPrefixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + liftIO $ expectedContentAfterAction @=? contentAfterAction + + +removeImportTests :: TestTree +removeImportTests = testGroup "remove import actions" + [ testSession "redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "qualified redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "stuffA = False" + , "stuffB :: Integer" + , "stuffB = 123" + , "stuffC = ()" + , "_stuffD = '_'" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove _stuffD, stuffA, stuffC from import" + =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding - unicode regression " $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "ε :: Double" + , "ε = 0.5" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), ε)" + , "a = A" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove ε from import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..))" + , "a = A" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant operator" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "a !! _b = a" + , "a _b = a" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A ((), stuffB, (!!))" + , "main = print A.stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove !!, from import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print A.stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant all import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), stuffB)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove A from import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant constructor import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data D = A | B" + , "data E = F" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(A,B), E(F))" + , "main = B" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove A, E, F from import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(B))" + , "main = B" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "import containing the identifier Strict" $ do + let contentA = T.unlines + [ "module Strict where" + ] + _docA <- createDoc "Strict.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import Strict" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove all" $ do + let content = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix, (&))" + , "import qualified Data.Functor.Const" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL, InR))" + , "import qualified Data.Kind as K (Constraint, Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + doc <- createDoc "ModuleC.hs" "haskell" content + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove all redundant imports" =<< getAllCodeActions doc + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix)" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL))" + , "import qualified Data.Kind as K (Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove unused operators whose name ends with '.'" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "(@.) = 0 -- Must have an operator whose name ends with '.'" + , "a = 1 -- .. but also something else" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a, (@.))" + , "x = a -- Must use something from module A, but not (@.)" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove @. from import" =<< getCodeActions docB (R 2 0 2 5) + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a)" + , "x = a -- Must use something from module A, but not (@.)" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testGroup "with checkAll" $ tests True + , testGroup "without checkAll" $ tests False + ] + where + tests overrideCheckProject = + [ testSession "extend all constructors for record field" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = B { a :: Int }" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A(B))" + , "f = a" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(a) to the import list of ModuleA" + , "Add a to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(..))" + , "f = a" + ]) + , testSession "extend all constructors with sibling" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors with comment" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors for type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add (:~:)(..) to the import list of Data.Type.Equality" + , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (..))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , testSession "extend all constructors for class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(..) to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(..))" + , "b = m2" + ]) + , testSession "extend single line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, stuffA)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add (.*) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, (.*))" + , "main = print (stuffB .* stuffB)" + ]) + , testSession "extend single line import with infix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList)" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + (Range (Position 2 5) (Position 2 6)) + [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" + , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" + ] + (T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + , testSession "extend single line import with prefix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes)" + , "x = Just 10" + ]) + (Range (Position 3 5) (Position 2 6)) + [ "Add Maybe(Just) to the import list of Data.Maybe" + , "Add Maybe(..) to the import list of Data.Maybe" + ] + (T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes, Maybe (Just))" + , "x = Just 10" + ]) + , testSession "extend single line import with type" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "type A = Double" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + , "b :: A" + , "b = 0" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = 0" + ]) + , testSession "extend single line import with constructor" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with constructor (with comments)" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A ({-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor{-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with mixed constructors" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = ConstructorFoo | ConstructorBar" + , "a = 1" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(ConstructorFoo) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + , brokenForGHC92 "On GHC 9.2, the error doesn't contain \"perhaps you want ...\" part from which import suggestion can be extracted." $ + testSession "extend single line import in presence of extra parens" $ template + [] + ("Main.hs", T.unlines + [ "import Data.Monoid (First)" + , "f = (First Nothing) <> mempty" -- parens tripped up the regex extracting import suggestions + ]) + (Range (Position 1 6) (Position 1 7)) + [ "Add First(..) to the import list of Data.Monoid" + , "Add First(First) to the import list of Data.Monoid" + ] + (T.unlines + [ "import Data.Monoid (First (..))" + , "f = (First Nothing) <> mempty" + ]) + , brokenForGHC94 "On GHC 9.4, the error messages with -fdefer-type-errors don't have necessary imported target srcspan info." $ + testSession "extend single line qualified import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB, stuffA)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA" + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend multi line import with trailing comma" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB," + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA," + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with method within class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1, m2))" + , "b = m2" + ]) + , testSession "extend single line import with method without class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add m2 to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1), m2)" + , "b = m2" + ]) + , testSession "extend import list with multiple choices" $ template + [("ModuleA.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleA (bar) where" + , "bar = 10" + ]), + ("ModuleB.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleB (bar) where" + , "bar = 10" + ])] + ("ModuleC.hs", T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA ()" + , "foo = bar" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add bar to the import list of ModuleA", + "Add bar to the import list of ModuleB"] + (T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA (bar)" + , "foo = bar" + ]) + , testSession "extend import list with constructor of type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" + , "Add (:~:)(..) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (Refl))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , expectFailBecause "importing pattern synonyms is unsupported" + $ testSession "extend import list with pattern synonym" $ template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ]) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ]) + , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $ + testSession "type constructor name same as data constructor name" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "newtype Foo = Foo Int" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = Foo 1" + ]) + (Range (Position 3 4) (Position 3 6)) + ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo (Foo))" + , "f :: Foo" + , "f = Foo 1" + ]) + , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo = Foo" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA()" + , "f :: Foo" + , "f = undefined" + ]) + (Range (Position 2 4) (Position 2 6)) + ["Add Foo to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = undefined" + ]) + ] + where + codeActionTitle CodeAction{_title=x} = x + + template setUpModules moduleUnderTest range expectedTitles expectedContentB = do + configureCheckProject overrideCheckProject + + mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + actionsOrCommands <- getCodeActions docB range + let codeActions = + [ ca | InR ca <- actionsOrCommands + , let title = codeActionTitle ca + , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) + ] + actualTitles = codeActionTitle <$> codeActions + -- Note that we are not testing the order of the actions, as the + -- order of the expected actions indicates which one we'll execute + -- in this test, i.e., the first one. + liftIO $ sort expectedTitles @=? sort actualTitles + + -- Execute the action with the same title as the first expected one. + -- Since we tested that both lists have the same elements (possibly + -- in a different order), this search cannot fail. + firstTitle:_ <- pure expectedTitles + Just action <- pure $ find ((firstTitle ==) . codeActionTitle) codeActions + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +fixModuleImportTypoTests :: TestTree +fixModuleImportTypoTests = testGroup "fix module import typo" + [ testSession "works when single module suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.Cha" + _ <- waitForDiagnostics + action <- pickActionWithTitle "replace with Data.Char" =<< getCodeActions doc (R 0 0 0 10) + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Char" + , testSession "works when multiple modules suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.I" + _ <- waitForDiagnostics + actions <- getCodeActions doc (R 0 0 0 10) + traverse_ (assertActionWithTitle actions) + [ "replace with Data.Eq" + , "replace with Data.Int" + , "replace with Data.Ix" + ] + replaceWithDataEq <- pickActionWithTitle "replace with Data.Eq" actions + executeCodeAction replaceWithDataEq + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Eq" + ] + +suggestImportClassMethodTests :: TestTree +suggestImportClassMethodTests = + testGroup + "suggest import class methods" + [ testGroup + "new" + [ testSession "via parent" $ + template' + "import Data.Semigroup (Semigroup(stimes))" + (Range (Position 4 2) (Position 4 8)), + testSession "top level" $ + template' + "import Data.Semigroup (stimes)" + (Range (Position 4 2) (Position 4 8)), + testSession "all" $ + template' + "import Data.Semigroup" + (Range (Position 4 2) (Position 4 8)) + ], + testGroup + "extend" + [ testSession "via parent" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add Semigroup(stimes) to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (Semigroup (stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add stimes to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ] + ] + ] + where + decls = + [ "data X = X", + "instance Semigroup X where", + " (<>) _ _ = X", + " stimes _ _ = X" + ] + template beforeContent range executeTitle expectedContent = do + doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) + _ <- waitForDiagnostics + waitForProgressDone + action <- pickActionWithTitle executeTitle =<< getCodeActions doc range + executeCodeAction action + content <- documentContents doc + liftIO $ T.unlines (expectedContent <> decls) @=? content + template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle] + +suggestImportTests :: TestTree +suggestImportTests = testGroup "suggest import actions" + [ testGroup "Dont want suggestion" + [ -- extend import + -- We don't want to suggest a new import, but extend existing imports + test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + -- data constructor + , test False [] "f = First" [] "import Data.Monoid (First)" + -- internal module + , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" + -- package not in scope + , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + -- don't omit the parent data type of a constructor + , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" + -- don't suggest data constructor when we only need the type + , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" + -- don't suggest all data constructors for the data type + , test False [] "f :: Bar" [] "import Bar (Bar(..))" + ] + , testGroup "want suggestion" + [ wantWait [] "f = foo" [] "import Foo (foo)" + , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" + , wantWait [] "f :: Bar" [] "import Bar (Bar)" + , wantWait [] "f = Bar" [] "import Bar (Bar(..))" + , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" + , test True [] "f = First" [] "import Data.Monoid (First(First))" + , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" + , test True [] "f = Version" [] "import Data.Version (Version(Version))" + , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" + , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" + , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = empty" [] "import Control.Applicative (empty)" + , test True [] "f = empty" [] "import Control.Applicative" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = (NE.:|)" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = (Data.List.NonEmpty.:|)" [] "import qualified Data.List.NonEmpty" + , test True [] "f = (B..|.)" [] "import qualified Data.Bits as B" + , test True [] "f = (Data.Bits..|.)" [] "import qualified Data.Bits" + , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" + , test True [] "f = pack" [] "import Data.Text (pack)" + , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" + , test True [] "f = [] & id" [] "import Data.Function ((&))" + , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" + , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" + , test True [] "f :: a ~~ b" [] "import Data.Type.Equality ((~~))" + , test True + ["qualified Data.Text as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + , "qualified Data.Functor as T" + , "qualified Data.Data as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" + ] + , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + ] + where + test = test' False + wantWait = test' True True + + test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do + configureCheckProject waitForCheckProject + let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other + after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _ <- waitForDiagnostics + -- there isn't a good way to wait until the whole project is checked atm + when waitForCheckProject $ liftIO $ sleep 0.5 + let defLine = fromIntegral $ length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + if wanted + then do + action <- pickActionWithTitle newImp actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + else + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] + +suggestAddRecordFieldImportTests :: TestTree +suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" + [ testGroup "The field is suggested when an instance resolution failure occurs" + [ ignoreForGhcVersions [GHC90, GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest + ] + ] + where + theTest = testSessionWithExtraFiles "hover" def $ \dir -> do + configureCheckProject False + let before = T.unlines ["module A where", "import B (Foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"] + after = T.unlines ["module A where", "import B (Foo, foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"] + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, B]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["module B where", "data Foo = Foo { foo :: Int }"] + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _ <- waitForDiagnostics + let defLine = 3 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + action <- pickActionWithTitle "Add foo to the import list of B" actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + + +suggestImportDisambiguationTests :: TestTree +suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" + [ testGroup "Hiding strategy works" + [ testGroup "fromList" + [ testCase "AVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use AVec for fromList, hiding other imports" + "HideFunction.expected.fromList.A.hs" + , testCase "BVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use BVec for fromList, hiding other imports" + "HideFunction.expected.fromList.B.hs" + ] + , testGroup "(++)" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use EVec for ++, hiding other imports" + "HideFunction.expected.append.E.hs" + , testCase "Hide functions without local" $ + compareTwo + "HideFunctionWithoutLocal.hs" [(8,8)] + "Use local definition for ++, hiding other imports" + "HideFunctionWithoutLocal.expected.hs" + , testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use Prelude for ++, hiding other imports" + "HideFunction.expected.append.Prelude.hs" + , testCase "Prelude and local definition, infix" $ + compareTwo + "HidePreludeLocalInfix.hs" [(2,19)] + "Use local definition for ++, hiding other imports" + "HidePreludeLocalInfix.expected.hs" + , testCase "AVec, indented" $ + compareTwo "HidePreludeIndented.hs" [(3,8)] + "Use AVec for ++, hiding other imports" + "HidePreludeIndented.expected.hs" + ] + , testGroup "Vec (type)" + [ testCase "AVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use AVec for Vec, hiding other imports" + "HideType.expected.A.hs" + , testCase "EVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use EVec for Vec, hiding other imports" + "HideType.expected.E.hs" + ] + ] + , testGroup "Qualify strategy" + [ testCase "won't suggest full name for qualified module" $ + withHideFunction [(8,9),(10,8)] $ \_ _ actions -> do + liftIO $ + assertBool "EVec.fromList must not be suggested" $ + "Replace with qualified: EVec.fromList" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + liftIO $ + assertBool "EVec.++ must not be suggested" $ + "Replace with qualified: EVec.++" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + , testGroup "fromList" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: E.fromList" + "HideFunction.expected.qualified.fromList.E.hs" + , testCase "Hide DuplicateRecordFields" $ + compareTwo + "HideQualifyDuplicateRecordFields.hs" [(9, 9)] + "Replace with qualified: AVec.fromList" + "HideQualifyDuplicateRecordFields.expected.hs" + , testCase "Duplicate record fields should not be imported" $ do + withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $ + \_ _ actions -> do + liftIO $ + assertBool "Hidings should not be presented while DuplicateRecordFields exists" $ + all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports" + | InR CodeAction { _title = actionTitle } <- actions] + withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $ + \_ _ actions -> do + liftIO $ + assertBool "ambiguity from DuplicateRecordFields should not be imported" $ + null actions + ] + , testGroup "(++)" + [ testCase "Prelude, parensed" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: Prelude.++" + "HideFunction.expected.qualified.append.Prelude.hs" + , testCase "Prelude, infix" $ + compareTwo + "HideQualifyInfix.hs" [(4,19)] + "Replace with qualified: Prelude.++" + "HideQualifyInfix.expected.hs" + , testCase "Prelude, left section" $ + compareTwo + "HideQualifySectionLeft.hs" [(4,15)] + "Replace with qualified: Prelude.++" + "HideQualifySectionLeft.expected.hs" + , testCase "Prelude, right section" $ + compareTwo + "HideQualifySectionRight.hs" [(4,18)] + "Replace with qualified: Prelude.++" + "HideQualifySectionRight.expected.hs" + ] + ] + ] + where + compareTwo original locs cmd expected = + withTarget original locs $ \dir doc actions -> do + expected <- liftIO $ + readFileUtf8 (dir expected) + action <- pickActionWithTitle cmd actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction + compareHideFunctionTo = compareTwo "HideFunction.hs" + withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do + doc <- openDoc file "haskell" + void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence") | loc <- locs])] + actions <- getAllCodeActions doc + k dir doc actions + withHideFunction = withTarget ("HideFunction" <.> "hs") + +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unused" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unused" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unused" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurrence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + waitForProgressDone + cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + +insertNewDefinitionTests :: TestTree +insertNewDefinitionTests = testGroup "insert new definition actions" + [ testSession "insert new function definition" $ do + let txtB = + ["foo True = select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define select :: [Bool] -> Bool" + =<< getCodeActions docB (R 0 0 0 50) + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "insert new function definition - with similar suggestion in scope" $ do + doc <- createDoc "Module.hs" "haskell" $ T.unlines + [ "import Control.Monad" -- brings `mplus` into scope, leading to additional suggestion + -- "Perhaps use \8216mplus\8217 (imported from Control.Monad)" + , "f :: Int -> Int" + , "f x = plus x x" + ] + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define plus :: Int -> Int -> Int" + =<< getCodeActions doc (R 2 0 2 13) + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= T.unlines + [ "import Control.Monad" + , "f :: Int -> Int" + , "f x = plus x x" + , "" + , "plus :: Int -> Int -> Int" + , "plus = _" + ] + , testSession "define a hole" $ do + let txtB = + ["foo True = _select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define select :: [Bool] -> Bool" + =<< getCodeActions docB (R 0 0 0 50) + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines ( + ["foo True = select [True]" + , "" + ,"foo False = False" + , "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "insert new function definition - Haddock comments" $ do + let start = [ "foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define select :: Int -> Bool" + =<< getCodeActions docB (R 1 0 0 50) + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - normal comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define select :: Int -> Bool" + =<< getCodeActions docB (R 1 0 0 50) + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - untyped error" $ do + let txtB = + ["foo = select" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + action <- pickActionWithTitle "Define select :: _" =<< getCodeActions docB (R 0 0 0 50) + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: _" + , "select = _" + ] + ++ txtB') + ] + + +deleteUnusedDefinitionTests :: TestTree +deleteUnusedDefinitionTests = testGroup "delete unused definition action" + [ testSession "delete unused top level binding" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "f :: Int -> Int" + , "f 1 = let a = 1" + , " in a" + , "f 2 = 2" + , "" + , "some = ()" + ] + (4, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] + , testSession "delete unused top level binding defined in infix form" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "myPlus :: Int -> Int -> Int" + , "a `myPlus` b = a + b" + , "" + , "some = ()" + ] + (4, 2) + "Delete ‘myPlus’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] + , testSession "delete unused binding in where clause" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , " h :: Int" + , " h = 4" + , "" + ] + (10, 4) + "Delete ‘h’" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , "" + ] + , testSession "delete unused binding with multi-oneline signatures front" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ] + (4, 0) + "Delete ‘a’" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "b, c :: Int" + , "b = 4" + , "c = 5" + ] + , testSession "delete unused binding with multi-oneline signatures mid" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ] + (5, 0) + "Delete ‘b’" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, c :: Int" + , "a = 3" + , "c = 5" + ] + , testSession "delete unused binding with multi-oneline signatures end" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ] + (6, 0) + "Delete ‘c’" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b :: Int" + , "a = 3" + , "b = 4" + ] + ] + where + testFor sourceLines pos@(l,c) expectedTitle expectedLines = do + docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines + expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used")]) ] + action <- pickActionWithTitle expectedTitle =<< getCodeActions docId (R l c l c) + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= T.unlines expectedLines + +addTypeAnnotationsToLiteralsTest :: TestTree +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" + [ testSession "add default type to satisfy one constraint" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = 1" + ] + (if ghcVersion >= GHC94 + then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable") ] + else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint") ]) + "Add type annotation ‘Integer’ to ‘1’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = (1 :: Integer)" + ] + + , testSession "add default type to satisfy one constraint in nested expressions" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = 3" + , " in x" + ] + (if ghcVersion >= GHC94 + then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable") ] + else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint") ]) + "Add type annotation ‘Integer’ to ‘3’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = (3 :: Integer)" + , " in x" + ] + , testSession "add default type to satisfy one constraint in more nested expressions" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = 5 in y" + , " in x" + ] + (if ghcVersion >= GHC94 + then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable") ] + else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint") ]) + "Add type annotation ‘Integer’ to ‘5’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = (5 :: Integer) in y" + , " in x" + ] + , testSession "add default type to satisfy one constraint with duplicate literals" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq \"debug\" traceShow \"debug\"" + ] + (if ghcVersion >= GHC94 + then + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable") + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable") + ] + else + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint") + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint") + ]) + "Add type annotation ‘String’ to ‘\"debug\"’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: String) traceShow \"debug\"" + ] + , testSession "add default type to satisfy two constraints" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow \"debug\" a" + ] + (if ghcVersion >= GHC94 + then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable") ] + else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint") ]) + "Add type annotation ‘String’ to ‘\"debug\"’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow (\"debug\" :: String) a" + ] + , testSession "add default type to satisfy two constraints with duplicate literals" $ + testFor + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" + ] + (if ghcVersion >= GHC94 + then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable") ] + else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint") ]) + "Add type annotation ‘String’ to ‘\"debug\"’" + [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: String)))" + ] + ] + where + testFor sourceLines diag expectedTitle expectedLines = do + docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines + expectDiagnostics [ ("A.hs", diag) ] + let cursors = map snd3 diag + (ls, cs) = minimum cursors + (le, ce) = maximum cursors + + action <- pickActionWithTitle expectedTitle =<< getCodeActions docId (R ls cs le ce) + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= T.unlines expectedLines + + +fixConstructorImportTests :: TestTree +fixConstructorImportTests = testGroup "fix import actions" + [ testSession "fix constructor import" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Constructor)" + ]) + (Range (Position 1 10) (Position 1 11)) + "Fix import of A(Constructor)" + (T.unlines + [ "module ModuleB where" + , "import ModuleA(A(Constructor))" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + action <- pickActionWithTitle expectedAction =<< getCodeActions docB range + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +importRenameActionTests :: TestTree +importRenameActionTests = testGroup "import rename actions" $ + fmap check ["Map", "Maybe"] + where + check modname = checkCodeAction + ("Data.Mape -> Data." <> T.unpack modname) + ("replace with Data." <> modname) + (T.unlines + [ "module Testing where" + , "import Data.Mape" + ]) + (T.unlines + [ "module Testing where" + , "import Data." <> modname + ]) + +fillTypedHoleTests :: TestTree +fillTypedHoleTests = let + + sourceCode :: T.Text -> T.Text -> T.Text -> T.Text + sourceCode a b c = T.unlines + [ "module Testing where" + , "" + , "globalConvert :: Int -> String" + , "globalConvert = undefined" + , "" + , "globalInt :: Int" + , "globalInt = 3" + , "" + , "bar :: Int -> Int -> String" + , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" + , " localConvert = (flip replicate) 'x'" + , "" + , "foo :: () -> Int -> String" + , "foo = undefined" + ] + + check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree + check actionTitle + oldA oldB oldC + newA newB newC = testSession (T.unpack actionTitle) $ do + let originalCode = sourceCode oldA oldB oldC + let expectedCode = sourceCode newA newB newC + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) + chosenAction <- pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "fill typed holes" + [ check "replace _ with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace _ with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + + , check "replace _convertme with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" + + , check "replace _b with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace _c with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + + , check "replace _c with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" + , check "replace _ with foo _" + "_" "n" "n" + "(foo _)" "n" "n" + , testSession "replace _toException with E.toException" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "import qualified Control.Exception as E" + , "ioToSome :: E.IOException -> E.SomeException" + , "ioToSome = " <> x ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) + chosen <- pickActionWithTitle "replace _toException with E.toException" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "E.toException" @=? modifiedCode + , testSession "filling infix type hole uses prefix notation" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "data A = A" + , "foo :: A -> A -> A" + , "foo A A = A" + , "test :: A -> A -> A" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) + chosen <- pickActionWithTitle "replace _ with foo" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "`foo`" @=? modifiedCode + , testSession "postfix hole uses postfix notation of infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = " <> x <> " a1 a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) + chosen <- pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "(+)" @=? modifiedCode + , testSession "filling infix type hole uses infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) + chosen <- pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "+" @=? modifiedCode + ] + +addInstanceConstraintTests :: TestTree +addInstanceConstraintTests = let + missingConstraintSourceCode :: Maybe T.Text -> T.Text + missingConstraintSourceCode mConstraint = + let constraint = maybe "" (<> " => ") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Wrap a = Wrap a" + , "" + , "instance " <> constraint <> "Eq (Wrap a) where" + , " (Wrap x) == (Wrap y) = x == y" + ] + + incompleteConstraintSourceCode :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode mConstraint = + let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "instance " <> constraint <> " => Eq (Pair a b) where" + , " (Pair x y) == (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode2 mConstraint = + let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "instance " <> constraint <> " => Eq (Three a b c) where" + , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = + checkCodeAction (T.unpack actionTitle) actionTitle originalCode expectedCode + + in testGroup "add instance constraint" + [ check + "Add `Eq a` to the context of the instance declaration" + (missingConstraintSourceCode Nothing) + (missingConstraintSourceCode $ Just "Eq a") + , check + "Add `Eq b` to the context of the instance declaration" + (incompleteConstraintSourceCode Nothing) + (incompleteConstraintSourceCode $ Just "Eq b") + , check + "Add `Eq c` to the context of the instance declaration" + (incompleteConstraintSourceCode2 Nothing) + (incompleteConstraintSourceCode2 $ Just "Eq c") + ] + +addFunctionConstraintTests :: TestTree +addFunctionConstraintTests = let + missingConstraintSourceCode :: T.Text -> T.Text + missingConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "eq :: " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + missingConstraintWithForAllSourceCode :: T.Text -> T.Text + missingConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "eq :: forall a. " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text + incompleteConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode :: T.Text -> T.Text + incompleteConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: T.Text -> T.Text + incompleteConstraintSourceCode2 constraint = + T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" + , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text + incompleteConstraintSourceCodeWithExtraCharsInContext constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = + T.unlines + [ "module Testing where" + , "data Pair a b = Pair a b" + , "eq " + , " :: (" <> constraint <> ")" + , " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] + + in testGroup "add function constraint" + [ checkCodeAction + "no preexisting constraint" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintSourceCode "") + (missingConstraintSourceCode "Eq a => ") + , checkCodeAction + "no preexisting constraint, with forall" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintWithForAllSourceCode "") + (missingConstraintWithForAllSourceCode "Eq a => ") + , checkCodeAction + "preexisting constraint, no parenthesis" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode "Eq a") + (incompleteConstraintSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraints in parenthesis" + "Add `Eq c` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode2 "(Eq a, Eq b)") + (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") + , checkCodeAction + "preexisting constraints with forall" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintWithForAllSourceCode "Eq a") + (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraint, with extra spaces in context" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") + , checkCodeAction + "preexisting constraint, with newlines in type signature" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") + ] + +checkCodeAction :: TestName -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] + +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + headerExt :: [T.Text] -> [T.Text] + headerExt exts = + redunt : extTxt ++ ["module Testing where"] + where + redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" + extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts + + redundantConstraintsCode :: Maybe T.Text -> T.Text + redundantConstraintsCode mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> "a -> a" + , "foo = id" + ] + + redundantMixedConstraintsCode :: Maybe T.Text -> T.Text + redundantMixedConstraintsCode mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureSpaces :: Maybe T.Text -> T.Text + typeSignatureSpaces mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + redundantConstraintsForall :: Maybe T.Text -> T.Text + redundantConstraintsForall mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ headerExt ["RankNTypes"] <> + [ "foo :: forall a. " <> constraint <> "a -> a" + , "foo = id" + ] + + typeSignatureDo :: Maybe T.Text -> T.Text + typeSignatureDo mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> IO ()" + , "f n = do" + , " let foo :: " <> constraint <> "a -> IO ()" + , " foo _ = return ()" + , " r n" + ] + + typeSignatureNested :: Maybe T.Text -> T.Text + typeSignatureNested mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: " <> constraint <> "a -> ()" + , " g _ = ()" + ] + + typeSignatureNested' :: Maybe T.Text -> T.Text + typeSignatureNested' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f =" + , " let" + , " g :: Int -> ()" + , " g = h" + , " where" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in g" + ] + + typeSignatureNested'' :: Maybe T.Text -> T.Text + typeSignatureNested'' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: Int -> ()" + , " g = " + , " let" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in h" + ] + + typeSignatureLined1 = T.unlines $ header <> + [ "foo :: Eq a =>" + , " a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined2 = T.unlines $ header <> + [ "foo :: (Eq a, Show a)" + , " => a -> Bool" + , "foo _ = True" + ] + + typeSignatureOneLine = T.unlines $ header <> + [ "foo :: a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined3 = T.unlines $ header <> + [ "foo :: ( Eq a" + , " , Show a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + typeSignatureLined3' = T.unlines $ header <> + [ "foo :: ( Eq a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = + checkCodeAction (T.unpack actionTitle) actionTitle originalCode expectedCode + + in testGroup "remove redundant function constraints" + [ check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "Eq a") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "(Eq a, Monoid a)") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (redundantMixedConstraintsCode $ Just "Monoid a, Show a") + (redundantMixedConstraintsCode Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `g`" + (typeSignatureNested $ Just "Eq a") + (typeSignatureNested Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested' $ Just "Eq a") + (typeSignatureNested' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested'' $ Just "Eq a") + (typeSignatureNested'' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsForall $ Just "Eq a") + (redundantConstraintsForall Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (typeSignatureDo $ Just "Eq a") + (typeSignatureDo Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (typeSignatureSpaces $ Just "Monoid a, Show a") + (typeSignatureSpaces Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + typeSignatureLined1 + typeSignatureOneLine + , check + "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" + typeSignatureLined2 + typeSignatureOneLine + , check + "Remove redundant constraint `Show a` from the context of the type signature for `foo`" + typeSignatureLined3 + typeSignatureLined3' + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" + , "module Sigs where" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before def = T.unlines $ header ++ [def] + after' def sig = T.unlines $ header ++ [sig, def] + + def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) + chosenAction <- pickActionWithTitle ("add signature: " <> sig) actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ "abc = True" >:: "abc :: Bool" + , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" + , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" + , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" + , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" + , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" + , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + ] + +exportUnusedTests :: TestTree +exportUnusedTests = testGroup "export unused actions" + [ testGroup "don't want suggestion" -- in this test group we check that no code actions are created + [ testSession "implicit exports" $ templateNoAction + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wmissing-signatures #-}" + , "module A where" + , "foo = id" + ] + (R 3 0 3 3) + "Export ‘foo’" + , testSession "not top-level" $ templateNoAction + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (foo,bar) where" + , "foo = ()" + , " where bar = ()" + , "bar = ()" + ] + (R 2 0 2 11) + "Export ‘bar’" + , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $ + testSession "type is exported but not the constructor of same name" $ templateNoAction + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "data Foo = Foo" + ] + (R 2 0 2 8) + "Export ‘Foo’" + , testSession "unused data field" $ templateNoAction + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(Foo)) where" + , "data Foo = Foo {foo :: ()}" + ] + (R 2 0 2 20) + "Export ‘foo’" + ] + , testGroup "want suggestion" + [ testSession "empty exports" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , ") where" + , "foo = id" + ] + (R 3 0 3 3) + "Export ‘foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , "foo) where" + , "foo = id" + ] + , testSession "single line explicit exports" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo) where" + , "foo = id" + , "bar = foo" + ] + (R 3 0 3 3) + "Export ‘bar’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo, bar) where" + , "foo = id" + , "bar = foo" + ] + , testSession "multi line explicit exports" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo) where" + , "foo = id" + , "bar = foo" + ] + (R 5 0 5 3) + "Export ‘bar’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo, bar) where" + , "foo = id" + , "bar = foo" + ] + , testSession "export list ends in comma" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " ) where" + , "foo = id" + , "bar = foo" + ] + (R 5 0 5 3) + "Export ‘bar’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " bar) where" + , "foo = id" + , "bar = foo" + ] + , testSession "style of multiple exports is preserved 1" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ] + (R 7 0 7 3) + "Export ‘baz’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ] + , testSession "style of multiple exports is preserved 2" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ] + (R 7 0 7 3) + "Export ‘baz’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar," + , " baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ] + , testSession "style of multiple exports is preserved and selects smallest export separator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ] + (R 10 0 10 4) + "Export ‘quux’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " , quux" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ] + , testSession "unused pattern synonym" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern Foo a <- (a, _)" + ] + (R 3 0 3 10) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern Foo) where" + , "pattern Foo a <- (a, _)" + ] + , testSession "unused data type" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "data Foo = Foo" + ] + (R 2 0 2 7) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "data Foo = Foo" + ] + , testSession "unused newtype" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "newtype Foo = Foo ()" + ] + (R 2 0 2 10) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "newtype Foo = Foo ()" + ] + , testSession "unused type synonym" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "type Foo = ()" + ] + (R 2 0 2 7) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "type Foo = ()" + ] + , testSession "unused type family" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A () where" + , "type family Foo p" + ] + (R 3 0 3 15) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A (Foo) where" + , "type family Foo p" + ] + , testSession "unused typeclass" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "class Foo a" + ] + (R 2 0 2 8) + "Export ‘Foo’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "class Foo a" + ] + , testSession "infix" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "a `f` b = ()" + ] + (R 2 0 2 11) + "Export ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (f) where" + , "a `f` b = ()" + ] + , testSession "function operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "(<|) = ($)" + ] + (R 2 0 2 9) + "Export ‘<|’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A ((<|)) where" + , "(<|) = ($)" + ] + , testSession "type synonym operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type (:<) = ()" + ] + (R 3 0 3 13) + "Export ‘:<’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A ((:<)) where" + , "type (:<) = ()" + ] + , testSession "type family operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type family (:<)" + ] + (R 4 0 4 15) + "Export ‘:<’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)) where" + , "type family (:<)" + ] + , testSession "typeclass operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "class (:<) a" + ] + (R 3 0 3 11) + "Export ‘:<’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "class (:<) a" + ] + , testSession "newtype operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "newtype (:<) = Foo ()" + ] + (R 3 0 3 20) + "Export ‘:<’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "newtype (:<) = Foo ()" + ] + , testSession "data type operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "data (:<) = Foo ()" + ] + (R 3 0 3 17) + "Export ‘:<’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "data (:<) = Foo ()" + ] + ] + ] + where + template origLines range actionTitle expectedLines = + exportTemplate (Just range) origLines actionTitle (Just expectedLines) + templateNoAction origLines range actionTitle = + exportTemplate (Just range) origLines actionTitle Nothing + +exportTemplate :: Maybe Range -> [T.Text] -> T.Text -> Maybe [T.Text] -> Session () +exportTemplate mRange initialLines expectedAction expectedLines = do + doc <- createDoc "A.hs" "haskell" $ T.unlines initialLines + _ <- waitForDiagnostics + actions <- case mRange of + Nothing -> getAllCodeActions doc + Just range -> getCodeActions doc range + case expectedLines of + Just content -> do + action <- pickActionWithTitle expectedAction actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.unlines content @=? contentAfterAction + Nothing -> + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +removeExportTests :: TestTree +removeExportTests = testGroup "remove export actions" + [ testSession "single export" $ template + [ "module A ( a ) where" + , "b :: ()" + , "b = ()" + ] + "Remove ‘a’ from export" + [ "module A ( ) where" + , "b :: ()" + , "b = ()" + ] + , testSession "ending comma" $ template + [ "module A ( a, ) where" + , "b :: ()" + , "b = ()" + ] + "Remove ‘a’ from export" + [ "module A ( ) where" + , "b :: ()" + , "b = ()" + ] + , testSession "multiple exports" $ template + [ "module A (a , c, b ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()" + ] + "Remove ‘b’ from export" + [ "module A (a , c ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()" + ] + , testSession "not in scope constructor" $ template + [ "module A (A (X,Y,Z,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ] + "Remove ‘Z’ from export" + [ "module A (A (X,Y,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ] + , testSession "multiline export" $ template + [ "module A (a" + , " , b" + , " , (:*:)" + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()" + ] + "Remove ‘:*:’ from export" + [ "module A (a" + , " , b" + , " " + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()" + ] + , testSession "qualified re-export" $ template + [ "module A (M.x,a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()" + ] + "Remove ‘M.x’ from export" + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()" + ] + , testSession "qualified re-export ending in '.'" $ template + [ "module A ((M.@.),a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()" + ] + "Remove ‘M.@.’ from export" + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()" + ] + , testSession "export module" $ template + [ "module A (module B) where" + , "a :: ()" + , "a = ()" + ] + "Remove ‘module B’ from export" + [ "module A () where" + , "a :: ()" + , "a = ()" + ] + , testSession "dodgy export" $ template + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X" + ] + "Remove ‘A(..)’ from export" + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X" + ] + , testSession "dodgy export" $ template + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X" + ] + "Remove ‘A(..)’ from export" + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X" + ] + , testSession "duplicate module export" $ template + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L,module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()" + ] + "Remove ‘Module L’ from export" + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()" + ] + , testSession "remove all exports single" $ template + [ "module A (x) where" + , "a :: ()" + , "a = ()" + ] + "Remove all redundant exports" + [ "module A () where" + , "a :: ()" + , "a = ()" + ] + , testSession "remove all exports two" $ template + [ "module A (x,y) where" + , "a :: ()" + , "a = ()" + ] + "Remove all redundant exports" + [ "module A () where" + , "a :: ()" + , "a = ()" + ] + , testSession "remove all exports three" $ template + [ "module A (a,x,y) where" + , "a :: ()" + , "a = ()" + ] + "Remove all redundant exports" + [ "module A (a) where" + , "a :: ()" + , "a = ()" + ] + , testSession "remove all exports composite" $ template + [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()" + ] + "Remove all redundant exports" + [ "module A (b, a, A(X, Y,getV), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()" + ] + ] + where + template origLines actionTitle expectedLines = + exportTemplate Nothing origLines actionTitle (Just expectedLines) + + +codeActionHelperFunctionTests :: TestTree +codeActionHelperFunctionTests = testGroup "code action helpers" + [ extendImportTestsRegEx + ] + +extendImportTestsRegEx :: TestTree +extendImportTestsRegEx = testGroup "regex parsing" + [ testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing + , testCase "parse malformed import list" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" + Nothing + , testCase "parse multiple imports" $ template + (if ghcVersion >= GHC98 + then "\n\8226 Add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (at app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (at app/testlsp.hs:8:1-29)" + else "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" + ) + $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) + ] + where + template message expected = do + liftIO $ expected @=? matchRegExMultipleImports message + +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> Session CodeAction +pickActionWithTitle title actions = + case matches of + [] -> liftIO . assertFailure $ "CodeAction with title " <> show title <> " not found in " <> show titles + a:_ -> pure a + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +assertNoActionWithTitle :: T.Text -> [Command |? CodeAction] -> Session () +assertNoActionWithTitle title actions = + liftIO $ assertBool + ("Unexpected code action " <> show title <> " in " <> show titles) + (title `notElem` titles) + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + +assertActionWithTitle :: [Command |? CodeAction] -> T.Text -> Session () +assertActionWithTitle actions title = + liftIO $ assertBool + ("CodeAction with title " <> show title <>" not found in " <> show titles) + (title `elem` titles) + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + +testSession :: TestName -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: HasCallStack => FilePath -> TestName -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +runWithExtraFiles :: HasCallStack => FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: HasCallStack => FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("plugins/hls-refactor-plugin/test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("plugins/hls-refactor-plugin/test/data" prefix f) (dir f) + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir act = do + plugin <- refactorPlugin + runSessionWithServer' plugin def def lspTestCaps dir act + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> + canonicalizePath dir >>= f + +brokenForGHC94 :: String -> TestTree -> TestTree +brokenForGHC94 = knownBrokenForGhcVersions [GHC94] + +brokenForGHC92 :: String -> TestTree -> TestTree +brokenForGHC92 = knownBrokenForGhcVersions [GHC92] diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.AddArgument (tests) where + +import qualified Data.Text as T +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokensEdit (_start), + mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit + + +import Test.Hls +import qualified Test.Hls.FileSystem as FS + +import qualified Development.IDE.Plugin.CodeAction as Refactor +import System.FilePath ((<.>)) + +tests :: TestTree +tests = + testGroup + "add argument" + [ mkGoldenAddArgTest' "Hole" (r 0 0 0 50) "_new_def", + mkGoldenAddArgTest "NoTypeSuggestion" (r 0 0 0 50), + mkGoldenAddArgTest "MultipleDeclAlts" (r 0 0 0 50), + mkGoldenAddArgTest "AddArgWithSig" (r 1 0 1 50), + mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50), + mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50), + mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50), + mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50), + mkGoldenAddArgTest "MultiSigFirst" (r 2 0 2 50), + mkGoldenAddArgTest "MultiSigLast" (r 2 0 2 50), + mkGoldenAddArgTest "MultiSigMiddle" (r 2 0 2 50) + ] + where + r x y x' y' = Range (Position x y) (Position x' y') + +mkGoldenAddArgTest :: FilePath -> Range -> TestTree +mkGoldenAddArgTest testFileName range = mkGoldenAddArgTest' testFileName range "new_def" + +-- Make a golden test for the add argument action. Given varName is the name of the variable not yet defined. +mkGoldenAddArgTest' :: FilePath -> Range -> T.Text -> TestTree +mkGoldenAddArgTest' testFileName range varName = do + let action docB = do + _ <- waitForDiagnostics + let matchAction a = case a of + InR CodeAction {_title = t} -> "Add" `T.isPrefixOf` t + _ -> False + InR action@CodeAction {_title = actionTitle} : _ <- + filter matchAction <$> getCodeActions docB range + liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function") + executeCodeAction action + goldenWithHaskellDocInTmpDir + def + (mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings") + (testFileName <> " (golden)") + (FS.mkVirtualFileTree "plugins/hls-refactor-plugin/test/data/golden/add-arg" (FS.directProject $ testFileName <.> "hs")) + testFileName + "expected" + "hs" + action diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.expected.hs @@ -0,0 +1,6 @@ +foo :: Bool -> _ -> Int +foo True new_def = + let bar = new_def + in bar + +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromLet.hs @@ -0,0 +1,6 @@ +foo :: Bool -> Int +foo True = + let bar = new_def + in bar + +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.expected.hs @@ -0,0 +1,6 @@ +foo :: Bool -> _ -> Int +foo True new_def = bar + where + bar = new_def + +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhere.hs @@ -0,0 +1,6 @@ +foo :: Bool -> Int +foo True = bar + where + bar = new_def + +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True new_def -- c4 + = new_def + +foo False new_def = False diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.expected.hs @@ -0,0 +1,4 @@ +foo :: Bool -> _ -> () -> Int +foo True new_def = \() -> new_def [True] + +foo False new_def = const 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithLambda.hs @@ -0,0 +1,4 @@ +foo :: Bool -> () -> Int +foo True = \() -> new_def [True] + +foo False = const 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.expected.hs @@ -0,0 +1,4 @@ +foo :: Bool -> _ -> Int +foo True new_def = new_def [True] + +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSig.hs @@ -0,0 +1,4 @@ +foo :: Bool -> Int +foo True = new_def [True] + +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs @@ -0,0 +1,11 @@ +foo :: + -- c1 + Bool -- c2 + -- c3 + -> -- c4 + -- | c5 + () -- c6 + -> _ -> Int +foo True () new_def = new_def [True] + +foo False () new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithSigAndDocs.hs @@ -0,0 +1,11 @@ +foo :: + -- c1 + Bool -- c2 + -- c3 + -> -- c4 + -- | c5 + () -- c6 + -> Int +foo True () = new_def [True] + +foo False () = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs @@ -0,0 +1,5 @@ +type FunctionTySyn = Bool -> Int +foo :: FunctionTySyn +foo True new_def = new_def [True] + +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSig.hs @@ -0,0 +1,5 @@ +type FunctionTySyn = Bool -> Int +foo :: FunctionTySyn +foo True = new_def [True] + +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs @@ -0,0 +1,5 @@ +type FunctionTySyn = Bool -> Int +foo :: FunctionTySyn -> () -> _ -> Int +foo True () new_def = new_def [True] + +foo False () new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs @@ -0,0 +1,5 @@ +type FunctionTySyn = Bool -> Int +foo :: FunctionTySyn -> () -> Int +foo True () = new_def [True] + +foo False () = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs @@ -0,0 +1,1 @@ +foo _new_def = _new_def diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs @@ -0,0 +1,1 @@ +foo = _new_def diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.expected.hs @@ -0,0 +1,6 @@ +bar :: Bool -> Int +foo :: Bool -> _ -> Int +bar = const 1 +foo True new_def = new_def [True] + +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigFirst.hs @@ -0,0 +1,5 @@ +foo, bar :: Bool -> Int +bar = const 1 +foo True = new_def [True] + +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.expected.hs @@ -0,0 +1,7 @@ +baz, bar :: Bool -> Int +foo :: Bool -> _ -> Int +bar = const 1 +foo True new_def = new_def [True] + +foo False new_def = 1 +baz = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigLast.hs @@ -0,0 +1,6 @@ +baz, bar, foo :: Bool -> Int +bar = const 1 +foo True = new_def [True] + +foo False = 1 +baz = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.expected.hs @@ -0,0 +1,7 @@ +baz, bar :: Bool -> Int +foo :: Bool -> _ -> Int +bar = const 1 +foo True new_def = new_def [True] + +foo False new_def = 1 +baz = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultiSigMiddle.hs @@ -0,0 +1,6 @@ +baz, foo, bar :: Bool -> Int +bar = const 1 +foo True = new_def [True] + +foo False = 1 +baz = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs @@ -0,0 +1,2 @@ +foo True new_def = new_def +foo False new_def = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs @@ -0,0 +1,2 @@ +foo True = new_def +foo False = 1 diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs @@ -0,0 +1,1 @@ +foo new_def = new_def diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs @@ -0,0 +1,1 @@ +foo = new_def diff --git a/plugins/hls-refactor-plugin/test/data/hiding/AVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/AVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/AVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/BVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/BVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/BVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/CVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/CVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/CVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/DVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/DVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/DVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/EVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/EVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/EVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/FVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/FVec.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/FVec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module FVec (RecA(..), RecB(..)) where + +data Vec a + +newtype RecA a = RecA { fromList :: [a] -> Vec a } + +newtype RecB a = RecB { fromList :: [a] -> Vec a } diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs @@ -0,0 +1,12 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E +import Prelude hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec ( (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec () +import BVec (fromList, (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (Prelude.++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = E.fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs @@ -0,0 +1,14 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) +import Prelude hiding ((++)) + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs @@ -0,0 +1,13 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs @@ -0,0 +1,5 @@ +module HidePreludeIndented where + + import AVec + import Prelude hiding ((++)) + op = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs @@ -0,0 +1,4 @@ +module HidePreludeIndented where + + import AVec + op = (++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs @@ -0,0 +1,9 @@ +module HidePreludeLocalInfix where +import Prelude hiding ((++)) + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs @@ -0,0 +1,8 @@ +module HidePreludeLocalInfix where + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs @@ -0,0 +1,10 @@ +module HideQualifyDuplicateRecordFields where + +import AVec +import BVec +import CVec +import DVec +import EVec +import FVec + +theFun = AVec.fromList diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs @@ -0,0 +1,10 @@ +module HideQualifyDuplicateRecordFields where + +import AVec +import BVec +import CVec +import DVec +import EVec +import FVec + +theFun = fromList diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs @@ -0,0 +1,5 @@ +module HideQualifyDuplicateRecordFieldsSelf where + +import FVec + +x = fromList diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs @@ -0,0 +1,5 @@ +module HideQualifyInfix where + +import AVec + +infixed xs ys = xs Prelude.++ ys diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs @@ -0,0 +1,5 @@ +module HideQualifyInfix where + +import AVec + +infixed xs ys = xs ++ ys diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs @@ -0,0 +1,5 @@ +module HideQualifySectionLeft where + +import AVec + +sectLeft xs = (Prelude.++ xs) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs @@ -0,0 +1,5 @@ +module HideQualifySectionLeft where + +import AVec + +sectLeft xs = (++ xs) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs @@ -0,0 +1,5 @@ +module HideQualifySectionRight where + +import AVec + +sectLeft xs = (xs Prelude.++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs @@ -0,0 +1,5 @@ +module HideQualifySectionRight where + +import AVec + +sectLeft xs = (xs ++) diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E hiding (Vec) + +type TheType = Vec diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec ( fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/plugins/hls-refactor-plugin/test/data/hiding/HideType.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/HideType.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/plugins/hls-refactor-plugin/test/data/hiding/hie.yaml b/plugins/hls-refactor-plugin/test/data/hiding/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hiding/hie.yaml @@ -0,0 +1,10 @@ +cradle: + direct: + arguments: + - -Wall + - AVec.hs + - BVec.hs + - CVec.hs + - DVec.hs + - EVec.hs + - FVec.hs diff --git a/plugins/hls-refactor-plugin/test/data/hover/Bar.hs b/plugins/hls-refactor-plugin/test/data/hover/Bar.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/plugins/hls-refactor-plugin/test/data/hover/Foo.hs b/plugins/hls-refactor-plugin/test/data/hover/Foo.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs b/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ diff --git a/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs b/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z diff --git a/plugins/hls-refactor-plugin/test/data/hover/hie.yaml b/plugins/hls-refactor-plugin/test/data/hover/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs @@ -0,0 +1,12 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- | Another comment +data SomethingElse = SomethingElse + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where + +-- | Another comment +data SomethingElse = SomethingElse + +-- | Some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +{- Some comment -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +data Something = Something + +-- | some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs @@ -0,0 +1,14 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Monoid + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +-- | a comment +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs @@ -0,0 +1,13 @@ +module Test +( SomeData(..) +) where + +import Data.Char + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +-- | a comment +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wprepositive-qualified-module #-} +import Control.Monad qualified as Control +main :: IO () +main = Control.when True $ putStrLn "hello" diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportPostQualified.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wprepositive-qualified-module #-} +main :: IO () +main = Control.when True $ putStrLn "hello" diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.expected.hs @@ -0,0 +1,3 @@ +import qualified Control.Monad as Control +main :: IO () +main = Control.when True $ putStrLn "hello" diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ImportQualified.hs @@ -0,0 +1,2 @@ +main :: IO () +main = Control.when True $ putStrLn "hello" diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where +import Data.Monoid + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test +( SomeData(..) +) where + +-- comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where +import Data.Char +import Data.Array +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Char +import Data.Array + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +{- Some multi + line comment +-} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} +import Data.Monoid + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs @@ -0,0 +1,14 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Bool +import Data.Eq +import Data.Monoid + +-- | A comment +class Semigroup a => SomeData a + +-- | another comment +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs @@ -0,0 +1,13 @@ +module Test +( SomeData(..) +) where + +import Data.Char +import Data.Bool +import Data.Eq + +-- | A comment +class Semigroup a => SomeData a + +-- | another comment +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +import Data.Monoid + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs @@ -0,0 +1,11 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs @@ -0,0 +1,10 @@ +module Test +( SomeData(..) +) where + +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs @@ -0,0 +1,7 @@ +module Test where +import Data.Monoid + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs @@ -0,0 +1,6 @@ +module Test where + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs @@ -0,0 +1,8 @@ +module Test where +import Data.Monoid + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs @@ -0,0 +1,7 @@ +module Test where + +newtype Something = S { foo :: Int } + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs @@ -0,0 +1,7 @@ +import Data.Monoid +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs @@ -0,0 +1,6 @@ +newtype Something = S { foo :: Int } + +-- | a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs @@ -0,0 +1,5 @@ +import Data.Monoid +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs @@ -0,0 +1,4 @@ +-- a comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text +import Data.Monoid + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test +( SomeData(..) +) where +import Data.Monoid + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +module Test +( SomeData(..) +) where + +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid + +{- | some multiline + comment + ... -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +{- | some multiline + comment + ... -} +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs @@ -0,0 +1,9 @@ +module Test +( SomeData(..) +) where +import Data.Monoid + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs @@ -0,0 +1,8 @@ +module Test +( SomeData(..) +) where + +-- no vertical bar comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs @@ -0,0 +1,18 @@ +module Asdf + (f + , where') + + where +import Data.Int + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs @@ -0,0 +1,17 @@ +module Asdf + (f + , where') + + where + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs @@ -0,0 +1,20 @@ +module Asdf + (f + , where') +-- hello +-- world + + where +import Data.Int + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs @@ -0,0 +1,19 @@ +module Asdf + (f + , where') +-- hello +-- world + + where + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs @@ -0,0 +1,16 @@ +module Asdf + + + where +import Data.Int + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs @@ -0,0 +1,15 @@ +module Asdf + + + where + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ide.Plugin.Rename (descriptor, E.Log) where + +import Compat.HieTypes +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.Except (ExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Bifunctor (first) +import Data.Foldable (fold) +import Data.Generics +import Data.Hashable +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.List.NonEmpty (NonEmpty ((:|)), + groupWith) +import qualified Data.Map as M +import Data.Maybe +import Data.Mod.Word +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE (Recorder, WithPriority, + usePropertyAction) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as E +import Development.IDE.Plugin.CodeAction +import Development.IDE.Spans.AtPoint +import Development.IDE.Types.Location +import HieDb.Query +import Ide.Plugin.Error +import Ide.Plugin.Properties +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server + +instance Hashable (Mod a) where hash n = hash (unMod n) + +descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentRename renameProvider + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties } + } + +renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename +renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do + nfp <- getNormalizedFilePathE uri + directOldNames <- getNamesAtPos state nfp pos + directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames + + {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have + indirect references through punned names. To find the transitive closure, we do a pass of + the direct references to find the references for any punned names. + See the `IndirectPuns` test for an example. -} + indirectOldNames <- concat . filter ((>1) . length) <$> + mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs + let oldNames = filter matchesDirect indirectOldNames ++ directOldNames + matchesDirect n = occNameFS (nameOccName n) `elem` directFS + where + directFS = map (occNameFS. nameOccName) directOldNames + refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames + + -- Validate rename + crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties + unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames + when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax" + + -- Perform rename + let newName = mkTcOcc $ T.unpack newNameText + filesRefs = collectWith locToUri refs + getFileEdit (uri, locations) = do + verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) + getSrcEdit state verTxtDocId (replaceRefs newName locations) + fileEdits <- mapM getFileEdit filesRefs + pure $ InL $ fold fileEdits + +-- | Limit renaming across modules. +failWhenImportOrExport :: + (MonadLsp config m) => + IdeState -> + NormalizedFilePath -> + HashSet Location -> + [Name] -> + ExceptT PluginError m () +failWhenImportOrExport state nfp refLocs names = do + pm <- runActionE "Rename.GetParsedModule" state + (useE GetParsedModule nfp) + let hsMod = unLoc $ pm_parsed_source pm + case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of + (mbModName, _) | not $ any (\n -> nameIsLocalOrFrom (replaceModName n mbModName) n) names + -> throwError $ PluginInternalError "Renaming of an imported name is unsupported" + (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports + -> throwError $ PluginInternalError "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwError $ PluginInternalError "Explicit export list required for renaming" + _ -> pure () + +--------------------------------------------------------------------------------------------------- +-- Source renaming + +-- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`. +getSrcEdit :: + (MonadLsp config m) => + IdeState -> + VersionedTextDocumentIdentifier -> + (ParsedSource -> ParsedSource) -> + ExceptT PluginError m WorkspaceEdit +getSrcEdit state verTxtDocId updatePs = do + ccs <- lift getClientCapabilities + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + annAst <- runActionE "Rename.GetAnnotatedParsedSource" state + (useE GetAnnotatedParsedSource nfp) + let ps = astA annAst + src = T.pack $ exactPrint ps + res = T.pack $ exactPrint (updatePs ps) + pure $ diffText ccs (verTxtDocId, src) res IncludeDeletions + +-- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name. +replaceRefs :: + OccName -> + HashSet Location -> + ParsedSource -> + ParsedSource +replaceRefs newName refs = everywhere $ + -- there has to be a better way... + mkT (replaceLoc @AnnListItem) `extT` + -- replaceLoc @AnnList `extT` -- not needed + -- replaceLoc @AnnParen `extT` -- not needed + -- replaceLoc @AnnPragma `extT` -- not needed + -- replaceLoc @AnnContext `extT` -- not needed + -- replaceLoc @NoEpAnns `extT` -- not needed + replaceLoc @NameAnn + where + replaceLoc :: forall an. LocatedAn an RdrName -> LocatedAn an RdrName + replaceLoc (L srcSpan oldRdrName) + | isRef (locA srcSpan) = L srcSpan $ replace oldRdrName + replaceLoc lOldRdrName = lOldRdrName + replace :: RdrName -> RdrName + replace (Qual modName _) = Qual modName newName + replace _ = Unqual newName + + isRef :: SrcSpan -> Bool + isRef = (`HS.member` refs) . unsafeSrcSpanToLoc + +--------------------------------------------------------------------------------------------------- +-- Reference finding + +-- | Note: We only find exact name occurrences (i.e. type reference "depth" is 0). +refsAtName :: + MonadIO m => + IdeState -> + NormalizedFilePath -> + Name -> + ExceptT PluginError m [Location] +refsAtName state nfp name = do + ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras + ast <- handleGetHieAst state nfp + dbRefs <- case nameModule_maybe name of + Nothing -> pure [] + Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb -> + findReferences + hieDb + True + (nameOccName name) + (Just $ moduleName mod) + (Just $ moduleUnit mod) + [fromNormalizedFilePath nfp] + ) + pure $ nameLocs name ast ++ dbRefs + +nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location] +nameLocs name (HAR _ _ rm _ _, pm) = + concatMap (mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst)) + (M.lookup (Right name) rm) + +--------------------------------------------------------------------------------------------------- +-- Util + +getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name] +getNamesAtPos state nfp pos = do + (HAR{hieAst}, pm) <- handleGetHieAst state nfp + pure $ getNamesAtPoint hieAst pos pm + +handleGetHieAst :: + MonadIO m => + IdeState -> + NormalizedFilePath -> + ExceptT PluginError m (HieAstResult, PositionMapping) +handleGetHieAst state nfp = + fmap (first removeGenerated) $ runActionE "Rename.GetHieAst" state $ useWithStaleE GetHieAst nfp + +-- | We don't want to rename in code generated by GHC as this gives false positives. +-- So we restrict the HIE file to remove all the generated code. +removeGenerated :: HieAstResult -> HieAstResult +removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} + where + go :: HieASTs a -> HieASTs a + go hf = + HieASTs (fmap goAst (getAsts hf)) + goAst (Node nsi sp xs) = Node (SourcedNodeInfo $ M.restrictKeys (getSourcedNodeInfo nsi) (S.singleton SourceInfo)) sp (map goAst xs) + +collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] +collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList + +locToUri :: Location -> Uri +locToUri (Location uri _) = uri + +unsafeSrcSpanToLoc :: SrcSpan -> Location +unsafeSrcSpanToLoc srcSpan = + case srcSpanToLocation srcSpan of + Nothing -> error "Invalid conversion from UnhelpfulSpan to Location" + Just location -> location + +locToFilePos :: Monad m => Location -> ExceptT PluginError m (NormalizedFilePath, Position) +locToFilePos (Location uri (Range pos _)) = (,pos) <$> getNormalizedFilePathE uri + +replaceModName :: Name -> Maybe ModuleName -> Module +replaceModName name mbModName = + mkModule (moduleUnit $ nameModule name) (fromMaybe (mkModuleName "Main") mbModName) + +--------------------------------------------------------------------------------------------------- +-- Config + +properties :: Properties '[ 'PropertyKey "crossModule" 'TBoolean] +properties = emptyProperties + & defineBooleanProperty #crossModule + "Enable experimental cross-module renaming" False diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Aeson +import qualified Data.Map as M +import Ide.Plugin.Config +import qualified Ide.Plugin.Rename as Rename +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +renamePlugin :: PluginTestDescriptor Rename.Log +renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename" + +-- See https://github.com/wz1000/HieDb/issues/45 +recordConstructorIssue :: String +recordConstructorIssue = "HIE references for record fields incorrect with GHC versions >= 9" + +tests :: TestTree +tests = testGroup "Rename" + [ goldenWithRename "Data constructor" "DataConstructor" $ \doc -> + rename doc (Position 0 15) "Op" + , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> + rename doc (Position 2 1) "quux" + , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + goldenWithRename "Field Puns" "FieldPuns" $ \doc -> + rename doc (Position 7 13) "bleh" + , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> + rename doc (Position 3 4) "y" + , goldenWithRename "Function name" "FunctionName" $ \doc -> + rename doc (Position 3 1) "baz" + , goldenWithRename "GADT" "Gadt" $ \doc -> + rename doc (Position 6 37) "Expr" + , goldenWithRename "Hidden function" "HiddenFunction" $ \doc -> + rename doc (Position 0 32) "quux" + , goldenWithRename "Imported function" "ImportedFunction" $ \doc -> + rename doc (Position 3 8) "baz" + , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> + rename doc (Position 0 22) "hiddenFoo" + , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc -> + rename doc (Position 4 23) "blah" + , goldenWithRename "Let expression" "LetExpression" $ \doc -> + rename doc (Position 5 11) "foobar" + , goldenWithRename "Qualified as" "QualifiedAs" $ \doc -> + rename doc (Position 3 10) "baz" + , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc -> + rename doc (Position 3 12) "foobar" + , goldenWithRename "Qualified function" "QualifiedFunction" $ \doc -> + rename doc (Position 3 12) "baz" + , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> + rename doc (Position 0 2) "fooBarQuux" + , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + goldenWithRename "Record field" "RecordField" $ \doc -> + rename doc (Position 6 9) "number" + , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> + rename doc (Position 1 1) "baz" + , goldenWithRename "Typeclass" "Typeclass" $ \doc -> + rename doc (Position 8 15) "Equal" + , goldenWithRename "Type constructor" "TypeConstructor" $ \doc -> + rename doc (Position 2 17) "BinaryTree" + , goldenWithRename "Type variable" "TypeVariable" $ \doc -> + rename doc (Position 0 13) "b" + ] + +goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithRename title path act = + goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act + +testDataDir :: FilePath +testDataDir = "plugins" "hls-rename-plugin" "test" "testdata" diff --git a/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs @@ -0,0 +1,4 @@ +data Expr = Op Int Int + +plus :: Expr -> Expr +plus (Op n m) = Op (n + m) 0 diff --git a/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs b/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs @@ -0,0 +1,4 @@ +data Expr = Apply Int Int + +plus :: Expr -> Expr +plus (Apply n m) = Apply (n + m) 0 diff --git a/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs @@ -0,0 +1,5 @@ +module ExportedFunction (quux) where + +quux :: Num p => [a] -> p +quux [] = 0 +quux xs = 1 diff --git a/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs @@ -0,0 +1,5 @@ +module ExportedFunction (foo) where + +foo :: Num p => [a] -> p +foo [] = 0 +foo xs = 1 diff --git a/plugins/hls-rename-plugin/test/testdata/FieldPuns.expected.hs b/plugins/hls-rename-plugin/test/testdata/FieldPuns.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FieldPuns.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module FieldPun () where + +newtype Foo = Foo { bleh :: Int } + +unFoo :: Foo -> Int +unFoo Foo{bleh} = bleh diff --git a/plugins/hls-rename-plugin/test/testdata/FieldPuns.hs b/plugins/hls-rename-plugin/test/testdata/FieldPuns.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FieldPuns.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module FieldPun () where + +newtype Foo = Foo { field :: Int } + +unFoo :: Foo -> Int +unFoo Foo{field} = field diff --git a/plugins/hls-rename-plugin/test/testdata/Foo.hs b/plugins/hls-rename-plugin/test/testdata/Foo.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs @@ -0,0 +1,4 @@ +module FunctionArgument () where + +foo :: Int -> Int +foo y = y + 1 diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs @@ -0,0 +1,4 @@ +module FunctionArgument () where + +foo :: Int -> Int +foo x = x + 1 diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionName.expected.hs b/plugins/hls-rename-plugin/test/testdata/FunctionName.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionName.expected.hs @@ -0,0 +1,6 @@ +main = do + x <- return $ baz 42 + return (baz x) +baz, bar :: Int -> Int +baz x = x + 1 +bar = (+ 1) . baz diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionName.hs b/plugins/hls-rename-plugin/test/testdata/FunctionName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionName.hs @@ -0,0 +1,6 @@ +main = do + x <- return $ foo 42 + return (foo x) +foo, bar :: Int -> Int +foo x = x + 1 +bar = (+ 1) . foo diff --git a/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs b/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} + +data Expr a where + Number :: Int -> Expr Int + Boolean :: Bool -> Expr Bool + Not :: Expr Bool -> Expr Bool + Even :: Expr Int -> Expr Bool + Add :: Enum a => Expr a -> Expr a -> Expr Int + Max :: Ord a => Expr a -> Expr a -> Expr a + +evaluate :: Expr a -> a +evaluate (Number n) = n +evaluate (Boolean p) = p +evaluate (Add n m) = fromEnum (evaluate n) + fromEnum (evaluate m) +evaluate (Even n) = even $ evaluate n +evaluate (Not p) = not $ evaluate p +evaluate (Max x y) = max (evaluate x) (evaluate y) diff --git a/plugins/hls-rename-plugin/test/testdata/Gadt.hs b/plugins/hls-rename-plugin/test/testdata/Gadt.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Gadt.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} + +data Expression a where + Number :: Int -> Expression Int + Boolean :: Bool -> Expression Bool + Not :: Expression Bool -> Expression Bool + Even :: Expression Int -> Expression Bool + Add :: Enum a => Expression a -> Expression a -> Expression Int + Max :: Ord a => Expression a -> Expression a -> Expression a + +evaluate :: Expression a -> a +evaluate (Number n) = n +evaluate (Boolean p) = p +evaluate (Add n m) = fromEnum (evaluate n) + fromEnum (evaluate m) +evaluate (Even n) = even $ evaluate n +evaluate (Not p) = not $ evaluate p +evaluate (Max x y) = max (evaluate x) (evaluate y) diff --git a/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs @@ -0,0 +1,4 @@ +import Foo hiding (quux) + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs @@ -0,0 +1,4 @@ +import Foo hiding (foo) + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs @@ -0,0 +1,4 @@ +import Foo hiding (hiddenFoo) + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs b/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs @@ -0,0 +1,4 @@ +import Foo hiding (foo) + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs @@ -0,0 +1,4 @@ +import Foo (baz) + +bar :: Int -> Int +bar = baz diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs @@ -0,0 +1,4 @@ +import Foo (foo) + +bar :: Int -> Int +bar = foo diff --git a/plugins/hls-rename-plugin/test/testdata/IndirectPuns.expected.hs b/plugins/hls-rename-plugin/test/testdata/IndirectPuns.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/IndirectPuns.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module IndirectPuns () where + +newtype Foo = Foo { blah :: Int } + +unFoo :: Foo -> Int +unFoo Foo{blah} = blah diff --git a/plugins/hls-rename-plugin/test/testdata/IndirectPuns.hs b/plugins/hls-rename-plugin/test/testdata/IndirectPuns.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/IndirectPuns.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module IndirectPuns () where + +newtype Foo = Foo { field :: Int } + +unFoo :: Foo -> Int +unFoo Foo{field} = field diff --git a/plugins/hls-rename-plugin/test/testdata/LetExpression.expected.hs b/plugins/hls-rename-plugin/test/testdata/LetExpression.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/LetExpression.expected.hs @@ -0,0 +1,10 @@ +module Let () where + +import Foo + +bar :: Int +bar = let foobar = 5 in + foobar * foobar + +quux :: Int +quux = Foo.foo 4 diff --git a/plugins/hls-rename-plugin/test/testdata/LetExpression.hs b/plugins/hls-rename-plugin/test/testdata/LetExpression.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/LetExpression.hs @@ -0,0 +1,10 @@ +module Let () where + +import Foo + +bar :: Int +bar = let foo = 5 in + foo * foo + +quux :: Int +quux = Foo.foo 4 diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs @@ -0,0 +1,4 @@ +import qualified Foo as F + +bar :: Int -> Int +bar = F.baz diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs @@ -0,0 +1,4 @@ +import qualified Foo as F + +bar :: Int -> Int +bar = F.foo diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs @@ -0,0 +1,4 @@ +import qualified Foo + +bar :: Int -> Int +bar = Foo.baz diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs @@ -0,0 +1,4 @@ +import qualified Foo + +bar :: Int -> Int +bar = Foo.foo diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs @@ -0,0 +1,7 @@ +import qualified Foo as F + +bar :: Int -> Int +bar x = F.foobar x + foo x + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs @@ -0,0 +1,7 @@ +import qualified Foo as F + +bar :: Int -> Int +bar x = F.foo x + foo x + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/RealignDo.expected.hs b/plugins/hls-rename-plugin/test/testdata/RealignDo.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RealignDo.expected.hs @@ -0,0 +1,4 @@ +fooBarQuux :: Maybe Integer +fooBarQuux = do x <- Just 5 + t <- Just 10 + pure $ x + t diff --git a/plugins/hls-rename-plugin/test/testdata/RealignDo.hs b/plugins/hls-rename-plugin/test/testdata/RealignDo.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RealignDo.hs @@ -0,0 +1,4 @@ +foo :: Maybe Integer +foo = do x <- Just 5 + t <- Just 10 + pure $ x + t diff --git a/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs b/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs @@ -0,0 +1,7 @@ +data Bam = Bam { + number :: Int, + s :: String +} + +foo :: Bam -> Bam +foo Bam {number = y} = Bam {number = y + 5, s = ""} diff --git a/plugins/hls-rename-plugin/test/testdata/RecordField.hs b/plugins/hls-rename-plugin/test/testdata/RecordField.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RecordField.hs @@ -0,0 +1,7 @@ +data Bam = Bam { + n :: Int, + s :: String +} + +foo :: Bam -> Bam +foo Bam {n = y} = Bam {n = y + 5, s = ""} diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs @@ -0,0 +1,4 @@ +baz :: Int -> Int +baz x = foo + 10 + where + foo = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs @@ -0,0 +1,4 @@ +foo :: Int -> Int +foo x = foo + 10 + where + foo = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs @@ -0,0 +1,5 @@ +data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Leaf a + +rotateRight :: BinaryTree a -> BinaryTree a +rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) +rotateRight t = t diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs @@ -0,0 +1,5 @@ +data Tree a = Node a (Tree a) (Tree a) | Leaf a + +rotateRight :: Tree a -> Tree a +rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) +rotateRight t = t diff --git a/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs b/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs @@ -0,0 +1,2 @@ +bar :: Maybe b -> Maybe b +bar a = a diff --git a/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs b/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs @@ -0,0 +1,2 @@ +bar :: Maybe a -> Maybe a +bar a = a diff --git a/plugins/hls-rename-plugin/test/testdata/Typeclass.expected.hs b/plugins/hls-rename-plugin/test/testdata/Typeclass.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Typeclass.expected.hs @@ -0,0 +1,10 @@ +module Typeclass () where + +class Equal a where + equals :: a -> a -> Bool + +instance Equal Int where + equals = (==) + +allEqual :: Equal a => [a] -> Bool +allEqual = all =<< equals . head diff --git a/plugins/hls-rename-plugin/test/testdata/Typeclass.hs b/plugins/hls-rename-plugin/test/testdata/Typeclass.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Typeclass.hs @@ -0,0 +1,10 @@ +module Typeclass () where + +class Equality a where + equals :: a -> a -> Bool + +instance Equality Int where + equals = (==) + +allEqual :: Equality a => [a] -> Bool +allEqual = all =<< equals . head diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -0,0 +1,24 @@ +cradle: + direct: + arguments: + - "DataConstructor" + - "ExportedFunction" + - "FieldPuns" + - "Foo" + - "FunctionArgument" + - "FunctionName" + - "Gadt" + - "HiddenFunction" + - "ImportHiding" + - "ImportedFunction" + - "IndirectPuns" + - "LetExpression" + - "QualifiedAs" + - "QualifiedFunction" + - "QualifiedShadowing" + - "RealignDo" + - "RecordField" + - "ShadowedName" + - "TypeClass" + - "TypeConstructor" + - "TypeVariable" diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -0,0 +1,789 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS -Wno-orphans #-} + +module Ide.Plugin.Retrie (descriptor) where + +import Control.Concurrent.STM (readTVarIO) +import Control.Exception.Safe (Exception (..), + SomeException, assert, + catch, throwIO, try) +import Control.Lens.Operators +import Control.Monad (forM, unless, when) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) + +import Control.Monad.Trans.Maybe (MaybeT) +import Data.Aeson (FromJSON (..), + ToJSON (..)) +import Data.Bifunctor (second) +import qualified Data.ByteString as BS +import Data.Data +import Data.Either (partitionEithers) +import Data.Hashable (unhashed) +import qualified Data.HashSet as Set +import Data.IORef.Extra (atomicModifyIORef'_, + newIORef, readIORef) +import Data.List.Extra (find, nubOrdOn) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Monoid (First (First)) +import Data.String (IsString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.Actions (lookupMod) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Shake (ShakeExtras (ShakeExtras, knownTargetsVar), + getShakeExtras, + hiedbWriter, + toKnownFiles, withHieDb) +import Development.IDE.GHC.Compat (GRHSs (GRHSs), + GenLocated (L), GhcPs, + GhcRn, + HsBindLR (FunBind), + HsExpr (HsApp, OpApp), + HsGroup (..), + HsValBindsLR (..), + HscEnv, ImportDecl (..), + LHsExpr, LRuleDecls, + Match, ModIface, + ModSummary (ModSummary, ms_hspp_buf, ms_mod), + Outputable, ParsedModule, + RuleDecl (HsRule), + RuleDecls (HsRules), + SourceText (..), + TyClDecl (SynDecl), + TyClGroup (..), fun_id, + isQual, isQual_maybe, + locA, mi_fixities, + moduleNameString, + ms_hspp_opts, + nameModule_maybe, + nameOccName, nameRdrName, + noLocA, occNameFS, + occNameString, + pattern IsBoot, + pattern NotBoot, + pattern RealSrcSpan, + pm_parsed_source, + rdrNameOcc, rds_rules, + srcSpanFile, topDir, + unLoc, unLocA) +import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat.Util hiding (catch, try) +import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource), + TransformT) +import Development.IDE.Spans.AtPoint (LookupModule, + nameToLocation) +import Development.IDE.Types.Shake (WithHieDb) +import qualified GHC as GHCGHC +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (PluginInternalError), + getNormalizedFilePathE) +import Ide.PluginUtils +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types as LSP +import Language.LSP.Server (ProgressCancellable (Cancellable), + sendNotification, + sendRequest, + withIndefiniteProgress) +import Retrie (Annotated (astA), + AnnotatedModule, + Fixity (Fixity), + FixityDirection (InfixL), + Options, Options_ (..), + Verbosity (Loud), + addImports, apply, + applyWithUpdate) +import Retrie.Context +import Retrie.CPP (CPP (NoCPP), parseCPP) +import Retrie.ExactPrint (fix, makeDeltaAst, + transformA, unsafeMkA) +import Retrie.Expr (mkLocatedHsVar) +import Retrie.Fixity (FixityEnv, lookupOp, + mkFixityEnv) +import Retrie.Monad (getGroundTerms, + runRetrie) +import Retrie.Options (defaultOptions, + getTargetFiles) +import Retrie.Replace (Change (..), + Replacement (..)) +import Retrie.Rewrites +import Retrie.Rewrites.Function (matchToRewrites) +import Retrie.SYB (everything, extQ, + listify, mkQ) +import Retrie.Types +import Retrie.Universe (Universe) +import System.Directory (makeAbsolute) + +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual +#endif + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId "Provides code actions to inline Haskell definitions") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider, + pluginCommands = [retrieCommand, retrieInlineThisCommand] + } + +retrieCommandId :: CommandId +retrieCommandId = "retrieCommand" + +retrieInlineThisCommandId :: CommandId +retrieInlineThisCommandId = "retrieInlineThisCommand" + +retrieCommand :: PluginCommand IdeState +retrieCommand = + PluginCommand retrieCommandId "run the refactoring" runRetrieCmd + +retrieInlineThisCommand :: PluginCommand IdeState +retrieInlineThisCommand = + PluginCommand retrieInlineThisCommandId "inline function call" + runRetrieInlineThisCmd + +-- | Parameters for the runRetrie PluginCommand. +data RunRetrieParams = RunRetrieParams + { description :: T.Text, + rewrites :: [RewriteSpec], + originatingFile :: Uri, + restrictToOriginatingFile :: Bool + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +runRetrieCmd :: CommandFunction IdeState RunRetrieParams +runRetrieCmd state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ + withIndefiniteProgress description token Cancellable $ \_updater -> do + _ <- runExceptT $ do + nfp <- getNormalizedFilePathE uri + (session, _) <- + runActionE "Retrie.GhcSessionDeps" state $ + useWithStaleE GhcSessionDeps + nfp + (ms, binds, _, _, _) <- runActionE "Retrie.getBinds" state $ getBinds nfp + let importRewrites = concatMap (extractImports ms binds) rewrites + (errors, edits) <- liftIO $ + callRetrie + state + (hscEnv session) + (map Right rewrites <> map Left importRewrites) + nfp + restrictToOriginatingFile + unless (null errors) $ + lift $ sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Warning $ + T.unlines $ + "## Found errors during rewrite:" : + ["-" <> T.pack (show e) | e <- errors] + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) + return () + return $ Right $ InR Null + +data RunRetrieInlineThisParams = RunRetrieInlineThisParams + { inlineIntoThisLocation :: !Location, + inlineFromThisLocation :: !Location, + inlineThisDefinition :: !T.Text + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams +runRetrieInlineThisCmd state _token RunRetrieInlineThisParams{..} = do + nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation + nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation + -- What we do here: + -- Find the identifier in the given position + -- Construct an inline rewrite for it + -- Run retrie to get a list of changes + -- Select the change that inlines the identifier in the given position + -- Apply the edit + astSrc <- runActionE "retrie" state $ + useE GetAnnotatedParsedSource nfpSource + let fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation + intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation + inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange + when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite" + (session, _) <- runActionE "retrie" state $ + useWithStaleE GhcSessionDeps nfp + (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp + result <- liftIO $ try @_ @SomeException $ + runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp + case result of + Left err -> throwError $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err) + Right (_,_,NoChange) -> throwError $ PluginInternalError "Retrie - inline produced no changes" + Right (_,_,Change replacements imports) -> do + let edits = asEditMap $ asTextEdits $ Change ourReplacement imports + wedit = WorkspaceEdit (Just edits) Nothing Nothing + ourReplacement = [ r + | r@Replacement{..} <- replacements + , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ InR Null + +-- Override to skip adding binders to the context, which prevents inlining +-- nested defined functions +myContextUpdater :: ContextUpdater +myContextUpdater c i = + updateContext c i + `extQ` (return . updExp) + `extQ` (skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs))) + `extQ` (skipUpdate @(Match GhcPs (LHsExpr GhcPs))) + where + skipUpdate :: forall a m . Monad m => a -> TransformT m Context + skipUpdate _ = pure c + + -- override to skip the HsLet case + updExp :: HsExpr GhcPs -> Context + updExp HsApp{} = + c { ctxtParentPrec = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL } + -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right) + -- In left child, prec is 10, so HsApp child will NOT get paren'd + -- In right child, prec is 11, so every child gets paren'd (unless atomic) + updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) } + updExp _ = c { ctxtParentPrec = NeverParen } + -- Deal with Trees-That-Grow adding extension points + -- as the first child everywhere. + firstChild :: Int + firstChild = 1 + +extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] +extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing) + | Just FunBind {fun_matches} + <- find (\case FunBind{fun_id = L _ n} -> T.unpack (printOutputable n) == thing ; _ -> False) topLevelBinds + , names <- listify p fun_matches + = + [ AddImport {..} + | let ideclSource = False, + name <- names, + let r = nameRdrName name, + let ideclQualifiedBool = isQual r, + let ideclAsString = moduleNameString . fst <$> isQual_maybe r, + let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r), + Just ideclNameString <- + [moduleNameString . GHC.moduleName <$> nameModule_maybe name] + ] + where + p name = nameModule_maybe name /= Just ms_mod +-- TODO handle imports for all rewrites +extractImports _ _ _ = [] + +------------------------------------------------------------------------------- + +provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = do + let (LSP.CodeActionContext _diags _monly _) = ca + nfp <- getNormalizedFilePathE uri + + (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) + <- runActionE "retrie" state $ + getBinds nfp + + extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras + + range <- fromCurrentRangeE posMapping range + let pos = range ^. L.start + let rewrites = + concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds + ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds + ++ [ r + | TyClGroup {group_tyclds} <- hs_tyclds, + L (locA -> l) g <- group_tyclds, + pos `isInsideSrcSpan` l, + r <- suggestTypeRewrites uri ms_mod g + ] + + retrieCommands <- lift $ + forM rewrites $ \(title, kind, params) -> liftIO $ do + let c = mkLspCommand plId retrieCommandId title (Just [toJSON params]) + return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing + + inlineSuggestions <- liftIO $ runIdeAction "" extras $ + suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter) + let inlineCommands = + [ Just $ + CodeAction _title (Just CodeActionKind_RefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing + | c@Command{..} <- inlineSuggestions + ] + return $ InL [InR c | c <- retrieCommands ++ catMaybes inlineCommands] + +getLocationUri :: Location -> Uri +getLocationUri Location{_uri} = _uri + +getLocationRange :: Location -> Range +getLocationRange Location{_range} = _range + +getBinds :: NormalizedFilePath -> ExceptT PluginError Action + ( ModSummary + , [HsBindLR GhcRn GhcRn] + , PositionMapping + , [LRuleDecls GhcRn] + , [TyClGroup GhcRn] + ) +getBinds nfp = do + (tm, posMapping) <- useWithStaleE TypeCheck nfp + -- we use the typechecked source instead of the parsed source + -- to be able to extract module names from the Ids, + -- so that we can include adding the required imports in the retrie command + let rn = tmrRenamed tm + case rn of + (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _) -> do + topLevelBinds <- case hs_valds of + ValBinds{} -> throwError $ PluginInternalError "getBinds: ValBinds not supported" + XValBindsLR (GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn) -> + pure [ decl + | (_, bagBinds) <- binds + , L _ decl <- bagToList bagBinds + ] + return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) + +suggestBindRewrites :: + Uri -> + Position -> + GHC.Module -> + HsBindLR GhcRn GhcRn -> + [(T.Text, CodeActionKind, RunRetrieParams)] +suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName} + | pos `isInsideSrcSpan` l' = + let pprNameText = printOutputable rdrName + pprName = T.unpack pprNameText + unfoldRewrite restrictToOriginatingFile = + let rewrites = [Unfold (qualify ms_mod pprName)] + description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) + foldRewrite restrictToOriginatingFile = + let rewrites = [Fold (qualify ms_mod pprName)] + description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) + in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] +suggestBindRewrites _ _ _ _ = [] + + -- find all the identifiers in the AST for which have source definitions +suggestBindInlines :: + PluginId + -> Uri + -> [HsBindLR GhcRn GhcRn] + -> Range + -> WithHieDb + -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri) + -> IdeAction [Command] +suggestBindInlines plId _uri binds range hie lookupMod = do + identifiers <- definedIdentifiers + return $ map (\(name, siteLoc, srcLoc) -> + let + title = "Inline " <> printedName + printedName = printOutputable name + params = RunRetrieInlineThisParams + { inlineIntoThisLocation = siteLoc + , inlineFromThisLocation = srcLoc + , inlineThisDefinition= printedName + } + in mkLspCommand plId retrieInlineThisCommandId title (Just [toJSON params]) + ) + (Set.toList identifiers) + where + definedIdentifiers = + -- we search for candidates to inline in RHSs only, skipping LHSs + everything (<>) (pure mempty `mkQ` getGRHSIdentifierDetails hie lookupMod) binds + + getGRHSIdentifierDetails :: + WithHieDb + -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri) + -> GRHSs GhcRn (LHsExpr GhcRn) + -> IdeAction (Set.HashSet (GHC.OccName, Location, Location)) + getGRHSIdentifierDetails a b it@GRHSs{} = + -- we only select candidates for which we have source code + everything (<>) (pure mempty `mkQ` getDefinedIdentifierDetailsViaHieDb a b) it + + getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location)) + getDefinedIdentifierDetailsViaHieDb withHieDb lookupModule lname | name <- unLoc lname = + case srcSpanToLocation (GHC.getLocA lname) of + Just siteLoc + | siteRange <- getLocationRange siteLoc + , range `isSubrangeOf` siteRange -> do + mbSrcLocation <- nameToLocation withHieDb lookupModule name + return $ maybe mempty (Set.fromList . map (nameOccName name, siteLoc,)) mbSrcLocation + _ -> pure mempty + + +describeRestriction :: IsString p => Bool -> p +describeRestriction restrictToOriginatingFile = + if restrictToOriginatingFile then " in current file" else "" + +suggestTypeRewrites :: + Uri -> + GHC.Module -> + TyClDecl GhcRn -> + [(T.Text, CodeActionKind, RunRetrieParams)] +suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} = + let pprNameText = printOutputable (unLocA tcdLName) + pprName = T.unpack pprNameText + unfoldRewrite restrictToOriginatingFile = + let rewrites = [TypeForward (qualify ms_mod pprName)] + description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) + foldRewrite restrictToOriginatingFile = + let rewrites = [TypeBackward (qualify ms_mod pprName)] + description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) + in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] +suggestTypeRewrites _ _ _ = [] + +suggestRuleRewrites :: + Uri -> + Position -> + GHC.Module -> + LRuleDecls GhcRn -> + [(T.Text, CodeActionKind, RunRetrieParams)] +suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = + concat + [ [ forwardRewrite ruleName True + , forwardRewrite ruleName False + , backwardsRewrite ruleName True + , backwardsRewrite ruleName False + ] + | L (locA -> l) r <- rds_rules, + pos `isInsideSrcSpan` l, +#if MIN_VERSION_ghc(9,5,0) + let HsRule {rd_name = L _ rn} = r, +#else + let HsRule {rd_name = L _ (_, rn)} = r, +#endif + let ruleName = unpackFS rn + ] + where + forwardRewrite ruleName restrictToOriginatingFile = + let rewrites = [RuleForward (qualify ms_mod ruleName)] + description = "Apply rule " <> T.pack ruleName <> " forward" <> + describeRestriction restrictToOriginatingFile + + in ( description, + CodeActionKind_Refactor, + RunRetrieParams {..} + ) + backwardsRewrite ruleName restrictToOriginatingFile = + let rewrites = [RuleBackward (qualify ms_mod ruleName)] + description = "Apply rule " <> T.pack ruleName <> " backwards" <> + describeRestriction restrictToOriginatingFile + in ( description, + CodeActionKind_Refactor, + RunRetrieParams {..} + ) + +qualify :: Outputable mod => mod -> String -> String +qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x + +------------------------------------------------------------------------------- +-- Retrie driving code + +data CallRetrieError + = CallRetrieInternalError String NormalizedFilePath + | NoParse NormalizedFilePath + | GHCParseError NormalizedFilePath String + | NoTypeCheck NormalizedFilePath + deriving (Eq, Typeable) + +instance Show CallRetrieError where + show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f + show (NoParse f) = "Cannot parse: " <> fromNormalizedFilePath f + show (GHCParseError f m) = "Cannot parse " <> fromNormalizedFilePath f <> " : " <> m + show (NoTypeCheck f) = "File does not typecheck: " <> fromNormalizedFilePath f + +instance Exception CallRetrieError + +callRetrie :: + IdeState -> + HscEnv -> + [Either ImportSpec RewriteSpec] -> + NormalizedFilePath -> + Bool -> + IO ([CallRetrieError], WorkspaceEdit) +callRetrie state session rewrites origin restrictToOriginatingFile = do + knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state) + let + -- TODO cover all workspaceFolders + target = "." + + retrieOptions :: Retrie.Options + retrieOptions = (defaultOptions target) + {Retrie.verbosity = Loud + ,Retrie.targetFiles = map fromNormalizedFilePath $ + if restrictToOriginatingFile + then [origin] + else Set.toList knownFiles + } + + (theImports, theRewrites) = partitionEithers rewrites + + annotatedImports = + unsafeMkA (map (noLocA . toImportDecl) theImports) 0 + + (originFixities, originParsedModule) <- reuseParsedModule state origin + retrie <- + (\specs -> apply specs >> addImports annotatedImports) + <$> parseSpecs state origin originParsedModule originFixities theRewrites + + targets <- getTargetFiles retrieOptions (getGroundTerms retrie) + + results <- forM targets $ \t -> runExceptT $ do + (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t + -- TODO add the imports to the resulting edits + (_user, _ast, change@(Change _replacements _imports)) <- + lift $ runRetrie fixityEnv retrie cpp + return $ asTextEdits change + + let (errors :: [CallRetrieError], replacements) = partitionEithers results + editParams :: WorkspaceEdit + editParams = + WorkspaceEdit (Just $ asEditMap $ concat replacements) Nothing Nothing + + return (errors, editParams) + +useOrFail :: + IdeRule r v => + IdeState -> + String -> + (NormalizedFilePath -> CallRetrieError) -> + r -> + NormalizedFilePath -> + IO (RuleResult r) +useOrFail state lbl mkException rule f = + useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return + +fixityEnvFromModIface :: ModIface -> FixityEnv +fixityEnvFromModIface modIface = + mkFixityEnv + [ (fs, (fs, fixity)) + | (n, fixity) <- mi_fixities modIface, + let fs = occNameFS n + ] + +fixFixities :: Data ast => + IdeState + -> NormalizedFilePath + -> Annotated ast + -> IO (FixityEnv, Annotated ast) +fixFixities state f pm = do + HiFileResult {hirModIface} <- + useOrFail state "GetModIface" NoTypeCheck GetModIface f + let fixities = fixityEnvFromModIface hirModIface + res <- transformA pm (fix fixities) + return (fixities, res) + +fixAnns :: ParsedModule -> Annotated GHC.ParsedSource +fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0 + +parseSpecs + :: IdeState + -> NormalizedFilePath + -> AnnotatedModule + -> FixityEnv + -> [RewriteSpec] + -> IO [Rewrite Universe] +parseSpecs state origin originParsedModule originFixities specs = do + -- retrie needs the libdir for `parseRewriteSpecs` + libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin + parseRewriteSpecs + libdir + (\_f -> return $ NoCPP originParsedModule) + originFixities + specs + +constructfromFunMatches :: + Annotated [GHCGHC.LocatedA (ImportDecl GhcPs)] + -> GHCGHC.LocatedN GHCGHC.RdrName + -> GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs)) + -> TransformT IO [Rewrite Universe] +constructfromFunMatches imps fun_id fun_matches = do + fe <- mkLocatedHsVar fun_id + rewrites <- concat <$> + forM (unLoc $ GHC.mg_alts fun_matches) (matchToRewrites fe imps LeftToRight) + let urewrites = toURewrite <$> rewrites + -- traceShowM $ map showQuery urewrites + assert (not $ null urewrites) $ + return urewrites + +-- showQuery :: Rewrite Universe -> String +-- showQuery = ppRewrite +-- +-- showQuery :: Rewrite (LHsExpr GhcPs) -> String +-- showQuery q = unlines +-- [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q)) +-- , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q)))) +-- , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q)) +-- ] +-- +-- s :: Data a => a -> String +-- s = T.unpack . printOutputable . showAstData NoBlankSrcSpan +-- NoBlankEpAnnotations + +constructInlineFromIdentifer :: Data a => Annotated (GenLocated l a) -> GHCGHC.RealSrcSpan -> IO [Rewrite Universe] +constructInlineFromIdentifer originParsedModule originSpan = do + -- traceM $ s $ astA originParsedModule + fmap astA $ transformA originParsedModule $ \(L _ m) -> do + let ast = everything (<>) (First Nothing `mkQ` matcher) m + matcher :: HsBindLR GhcPs GhcPs + -> First ( GHCGHC.LocatedN GHCGHC.RdrName + , GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs)) + ) + matcher FunBind{fun_id, fun_matches} + -- trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined + | RealSrcSpan sp _ <- GHC.getLocA fun_id + , sp == originSpan = + First $ Just (fun_id, fun_matches) + matcher _ = First Nothing + case ast of + First (Just (fun_id, fun_matches)) + -> + let imports = mempty in + constructfromFunMatches imports fun_id fun_matches + _ -> return $ error "could not find source code to inline" + +asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit] +asEditMap = Map.fromListWith (++) . map (second pure) + +asTextEdits :: Change -> [(Uri, TextEdit)] +asTextEdits NoChange = [] +asTextEdits (Change reps _imports) = + [ (filePathToUri spanLoc, edit) + | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps, + (RealSrcSpan rspan _) <- [replLocation], + let spanLoc = unpackFS $ srcSpanFile rspan, + let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement) + ] + +------------------------------------------------------------------------------- +-- Rule wrappers + +_useRuleBlocking, + _useRuleStale, + useRule :: + (IdeRule k v) => + String -> + IdeState -> + k -> + NormalizedFilePath -> + IO (Maybe (RuleResult k)) +_useRuleBlocking label state rule f = runAction label state (use rule f) +_useRuleStale label state rule f = + fmap fst + <$> runIdeAction label (shakeExtras state) (useWithStaleFast rule f) + +-- | Chosen approach for calling ghcide Shake rules +useRule label = _useRuleStale ("Retrie." <> label) + +------------------------------------------------------------------------------- +-- Serialization wrappers and instances + +deriving instance Eq RewriteSpec + +deriving instance Show RewriteSpec + +deriving instance Generic RewriteSpec + +deriving instance FromJSON RewriteSpec + +deriving instance ToJSON RewriteSpec + +newtype IE name + = IEVar name + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + + +data ImportSpec = AddImport + { ideclNameString :: String, + ideclSource :: Bool, + ideclQualifiedBool :: Bool, + ideclAsString :: Maybe String, + ideclThing :: Maybe (IE String) + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs +toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} + where + ideclSource' = if ideclSource then IsBoot else NotBoot + toMod = noLocA . GHC.mkModuleName + ideclName = toMod ideclNameString + ideclSafe = False + ideclImplicit = False + ideclSourceSrc = NoSourceText + ideclAs = toMod <$> ideclAsString + ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified + +#if MIN_VERSION_ghc(9,3,0) + ideclPkgQual = NoRawPkgQual +#else + ideclPkgQual = Nothing +#endif + +#if MIN_VERSION_ghc(9,5,0) + ideclImportList = Nothing + ideclExt = GHCGHC.XImportDeclPass + { ideclAnn = GHCGHC.EpAnnNotUsed + , ideclSourceText = ideclSourceSrc + , ideclImplicit = ideclImplicit + } +#else + ideclExt = GHCGHC.EpAnnNotUsed + ideclHiding = Nothing +#endif + + +reuseParsedModule :: IdeState -> NormalizedFilePath -> IO (FixityEnv, Annotated GHCGHC.ParsedSource) +reuseParsedModule state f = do + pm <- useOrFail state "Retrie.GetParsedModule" NoParse GetParsedModule f + (fixities, pm') <- fixFixities state f (fixAnns pm) + return (fixities, pm') + +getCPPmodule :: IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) +getCPPmodule state session t = do + nt <- toNormalizedFilePath' <$> makeAbsolute t + let getParsedModule f contents = do + modSummary <- msrModSummary <$> + useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt + let ms' = + modSummary + { ms_hspp_buf = + Just (stringToStringBuffer contents) + } + logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t + parsed <- evalGhcEnv session (GHCGHC.parseModule ms') + `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) + (fixities, parsed) <- fixFixities state f (fixAnns parsed) + return (fixities, parsed) + + contents <- do + (_, mbContentsVFS) <- + runAction "Retrie.GetFileContents" state $ getFileContents nt + case mbContentsVFS of + Just contents -> return contents + Nothing -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt) + if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents) + then do + fixitiesRef <- newIORef mempty + let parseModule x = do + (fix, res) <- getParsedModule nt x + atomicModifyIORef'_ fixitiesRef (fix <>) + return res + res <- parseCPP parseModule contents + fixities <- readIORef fixitiesRef + return (fixities, res) + else do + (fixities, pm) <- reuseParsedModule state nt + return (fixities, NoCPP pm) diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module Main (main) where + +import Control.Monad (void) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Development.IDE.GHC.ExactPrint +import qualified Development.IDE.Plugin.CodeAction as Refactor +import Ide.Plugin.Config +import qualified Ide.Plugin.Retrie as Retrie +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +retriePlugin :: PluginTestDescriptor a +retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie" + +refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor" + +tests :: TestTree +tests = testGroup "Retrie" + [ inlineThisTests + ] + +inlineThisTests :: TestTree +inlineThisTests = testGroup "Inline this" + [ + testGroup "provider" [ + testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"], + testProvider "identifier" "Identity" 4 16 ["Inline identity"], + testProvider "imported identifier" "Imported" 4 12 ["Inline identity"], + testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"], + testProvider "nested let" "NestedLet" 6 12 ["Inline identity"], + testProvider "class member" "Class" 5 16 [], + testProvider "operator" "Operator" 4 16 ["Inline */"] + ], + testGroup "command" [ + testCommand "top level function" "Identity" 4 16, + testCommand "top level function in another file" "Imported" 4 12, + testCommand "nested where function" "NestedWhere" 4 16, + testCommand "nested let function" "NestedLet" 6 12, + testCommand "operator" "Operator" 4 16 + ] + ] + +testProvider :: TestName -> FilePath -> UInt -> UInt -> [Text] -> TestTree +testProvider title file line row expected = testCase title $ runWithRetrie $ do + adoc <- openDoc (file <.> "hs") "haskell" + _ <- waitForTypecheck adoc + let position = Position line row + codeActions <- getCodeActions adoc $ Range position position + liftIO $ map codeActionTitle codeActions @?= map Just expected + +testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree +testCommand title file row col = goldenWithRetrie title file $ \adoc -> do + _ <- waitForTypecheck adoc + let p = Position row col + codeActions <- getCodeActions adoc $ Range p p + case codeActions of + [InR ca] -> do + executeCodeAction ca + void $ skipManyTill anyMessage $ getDocumentEdit adoc + cas -> liftIO . assertFailure $ "One code action expected, got " <> show (length cas) + +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle (InR CodeAction {_title}) = Just _title +codeActionTitle _ = Nothing + +goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithRetrie title path act = + goldenWithHaskellDoc (def { plugins = M.fromList [("retrie", def)] }) testPlugins title testDataDir path "expected" "hs" act + +runWithRetrie :: Session a -> IO a +runWithRetrie = runSessionWithServer def testPlugins testDataDir + +testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +testPlugins = + retriePlugin <> + refactorPlugin -- needed for the GetAnnotatedParsedSource rule + +testDataDir :: FilePath +testDataDir = "plugins" "hls-retrie-plugin" "test" "testdata" diff --git a/plugins/hls-retrie-plugin/test/testdata/Class.hs b/plugins/hls-retrie-plugin/test/testdata/Class.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Class.hs @@ -0,0 +1,7 @@ +module Class where + +class Identity x where + identity :: x -> x + identity x = x + +function x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs @@ -0,0 +1,5 @@ +module Identity where + +identity x = x + +function x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Identity.hs b/plugins/hls-retrie-plugin/test/testdata/Identity.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Identity.hs @@ -0,0 +1,5 @@ +module Identity where + +identity x = x + +function x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs @@ -0,0 +1,5 @@ +module Imported where + +import Identity + +f x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Imported.hs b/plugins/hls-retrie-plugin/test/testdata/Imported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Imported.hs @@ -0,0 +1,5 @@ +module Imported where + +import Identity + +f x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs @@ -0,0 +1,7 @@ +module Nested where + + + +function x = x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs b/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs @@ -0,0 +1,7 @@ +module NestedLet where + + + +function x = + let identity x = x + in x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs b/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs @@ -0,0 +1,7 @@ +module NestedLet where + + + +function x = + let identity x = x + in identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs b/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs @@ -0,0 +1,10 @@ + +module NestedNested where + + + +function x = meme x + where + meme x = identity x + identity x = x + diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs @@ -0,0 +1,7 @@ +module NestedWhere where + + + +function x = x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs @@ -0,0 +1,7 @@ +module NestedWhere where + + + +function x = identity x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs @@ -0,0 +1,5 @@ +module Operator where + +x */ y = x + +function x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Operator.hs b/plugins/hls-retrie-plugin/test/testdata/Operator.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Operator.hs @@ -0,0 +1,5 @@ +module Operator where + +x */ y = x + +function x = x */ () diff --git a/plugins/hls-retrie-plugin/test/testdata/hie.yaml b/plugins/hls-retrie-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/hie.yaml @@ -0,0 +1,11 @@ +cradle: + direct: + arguments: + - Class.hs + - Identity.hs + - Imported.hs + - Nested.hs + - NestedLet.hs + - NestedNested.hs + - NestedWhere.hs + - Operator.hs diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Ide.Plugin.SemanticTokens (descriptor) where + +import Development.IDE +import qualified Ide.Plugin.SemanticTokens.Internal as Internal +import Ide.Plugin.SemanticTokens.Types +import Ide.Types +import Language.LSP.Protocol.Message + +descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId "Provides semantic tokens") + { Ide.Types.pluginHandlers = + mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder) + <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder), + Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder, + pluginConfigDescriptor = + defaultConfigDescriptor + { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False} + , configCustomConfig = mkCustomConfig Internal.semanticConfigProperties + } + } diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnicodeSyntax #-} + +-- | +-- This module provides the core functionality of the plugin. +module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where + +import Control.Concurrent.STM (stateTVar) +import Control.Concurrent.STM.Stats (atomically) +import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT, liftEither, + withExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (Action, + GetDocMap (GetDocMap), + GetHieAst (GetHieAst), + HieAstResult (HAR, hieAst, hieModule, refMap), + IdeResult, IdeState, + Priority (..), + Recorder, Rules, + WithPriority, + cmapWithPrio, define, + fromNormalizedFilePath, + hieKind, use_) +import Development.IDE.Core.PluginUtils (runActionE, + useWithStaleE) +import Development.IDE.Core.Rules (toIdeResult) +import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) +import Development.IDE.Core.Shake (ShakeExtras (..), + getShakeExtras, + getVirtualFile, + useWithStale_) +import Development.IDE.GHC.Compat hiding (Warning) +import Development.IDE.GHC.Compat.Util (mkFastString) +import Ide.Logger (logWith) +import Ide.Plugin.Error (PluginError (PluginInternalError), + getNormalizedFilePathE, + handleMaybe, + handleMaybeM) +import Ide.Plugin.SemanticTokens.Mappings +import Ide.Plugin.SemanticTokens.Query +import Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions) +import Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) +import Ide.Plugin.SemanticTokens.Types +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (MessageResult, + Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta)) +import Language.LSP.Protocol.Types (NormalizedFilePath, + SemanticTokens, + type (|?) (InL, InR)) +import Prelude hiding (span) +import qualified StmContainers.Map as STM + + +$mkSemanticConfigFunctions + +----------------------- +---- the api +----------------------- + +computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens +computeSemanticTokens recorder pid _ nfp = do + config <- lift $ useSemanticConfigAction pid + logWith recorder Debug (LogConfig config) + semanticId <- lift getAndIncreaseSemanticTokensId + (RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp + withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList + +semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull +semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull + where + computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) + computeSemanticTokensFull = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + items <- computeSemanticTokens recorder pid state nfp + lift $ setSemanticTokens nfp items + return $ InL items + + +semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta +semanticTokensFullDelta recorder state pid param = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + let previousVersionFromParam = param ^. L.previousResultId + runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp + where + computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) + computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do + semanticTokens <- computeSemanticTokens recorder pid state nfp + previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp + lift $ setSemanticTokens nfp semanticTokens + case previousSemanticTokensMaybe of + Nothing -> return $ InL semanticTokens + Just previousSemanticTokens -> + if Just previousVersionFromParam == previousSemanticTokens^.L.resultId + then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens + else do + logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId)) + return $ InL semanticTokens + +-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. +-- +-- This Rule collects information from various sources, including: +-- +-- Imported name token type from Rule 'GetDocMap' +-- Local names token type from 'hieAst' +-- Name locations from 'hieAst' +-- Visible names from 'tmrRenamed' + +-- +-- It then combines this information to compute the semantic tokens for the file. +getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules () +getSemanticTokensRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do + (HAR {..}) <- lift $ use_ GetHieAst nfp + (DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp + ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp + virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp + let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap + return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast + + +-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs + +-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log) +handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a) +handleError recorder action' = do + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Warning msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) + +----------------------- +-- helper functions +----------------------- + +-- keep track of the semantic tokens response id +-- so that we can compute the delta between two versions +getAndIncreaseSemanticTokensId :: Action SemanticTokenId +getAndIncreaseSemanticTokensId = do + ShakeExtras{semanticTokensId} <- getShakeExtras + liftIO $ atomically $ do + i <- stateTVar semanticTokensId (\val -> (val, val+1)) + return $ T.pack $ show i + +getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache + +setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action () +setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + + +-- | +-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for: +-- +-- 1. Mapping semantic token type to and from the LSP default token type. +-- 2. Mapping from GHC type and tyThing to semantic token type. +-- 3. Mapping from hieAst identifier details to haskell semantic token type. +-- 4. Mapping from LSP tokens to SemanticTokenOriginal. +module Ide.Plugin.SemanticTokens.Mappings where + +import qualified Data.Array as A +import Data.List.Extra (chunksOf, (!?)) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text, unpack) +import Development.IDE (HieKind (HieFresh, HieFromDisk)) +import Development.IDE.GHC.Compat +import Ide.Plugin.SemanticTokens.Types +import Ide.Plugin.SemanticTokens.Utils (mkRange) +import Language.LSP.Protocol.Types (LspEnum (knownValues), + SemanticTokenAbsolute (SemanticTokenAbsolute), + SemanticTokenRelative (SemanticTokenRelative), + SemanticTokenTypes (..), + SemanticTokens (SemanticTokens), + UInt, absolutizeTokens) +import Language.LSP.VFS hiding (line) + +-- * 0. Mapping name to Hs semantic token type. + +nameInfixOperator :: Name -> Maybe HsSemanticTokenType +nameInfixOperator name | isSymOcc (nameOccName name) = Just TOperator +nameInfixOperator _ = Nothing + +-- * 1. Mapping semantic token type to and from the LSP default token type. + +-- | map from haskell semantic token type to LSP default token type +toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes +toLspTokenType conf tk = case tk of + TFunction -> stFunction conf + TVariable -> stVariable conf + TClassMethod -> stClassMethod conf + TTypeVariable -> stTypeVariable conf + TDataConstructor -> stDataConstructor conf + TClass -> stClass conf + TTypeConstructor -> stTypeConstructor conf + TTypeSynonym -> stTypeSynonym conf + TTypeFamily -> stTypeFamily conf + TRecordField -> stRecordField conf + TPatternSynonym -> stPatternSynonym conf + TModule -> stModule conf + TOperator -> stOperator conf + +lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType +lspTokenReverseMap config + | length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection" + | otherwise = mr + where xs = enumFrom minBound + mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs + +lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType +lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf) + +-- * 2. Mapping from GHC type and tyThing to semantic token type. + +-- | tyThingSemantic +tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType +tyThingSemantic ty | (Just hst) <- tyThingSemantic' ty = Just hst <> nameInfixOperator (getName ty) +tyThingSemantic _ = Nothing +tyThingSemantic' :: TyThing -> Maybe HsSemanticTokenType +tyThingSemantic' ty = case ty of + AnId vid + | isTyVar vid -> Just TTypeVariable + | isRecordSelector vid -> Just TRecordField + | isClassOpId vid -> Just TClassMethod + | isFunVar vid -> Just TFunction + | otherwise -> Just TVariable + AConLike con -> case con of + RealDataCon _ -> Just TDataConstructor + PatSynCon _ -> Just TPatternSynonym + ATyCon tyCon + | isTypeSynonymTyCon tyCon -> Just TTypeSynonym + | isTypeFamilyTyCon tyCon -> Just TTypeFamily + | isClassTyCon tyCon -> Just TClass + -- fall back to TTypeConstructor the result + | otherwise -> Just TTypeConstructor + ACoAxiom _ -> Nothing + where + isFunVar :: Var -> Bool + isFunVar var = isFunType $ varType var + +-- expand the type synonym https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Core.Type.html +expandTypeSyn :: Type -> Type +expandTypeSyn ty + | Just ty' <- coreView ty = expandTypeSyn ty' + | otherwise = ty + +isFunType :: Type -> Bool +isFunType a = case expandTypeSyn a of + ForAllTy _ t -> isFunType t + -- Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish + -- (->, =>, etc..) + FunTy flg _ rhs -> isVisibleFunArg flg || isFunType rhs + _x -> isFunTy a + + +hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a +hieKindFunMasksKind hieKind = case hieKind of + HieFresh -> HieFreshFun + HieFromDisk full_file -> HieFromDiskFun $ recoverFunMaskArray (hie_types full_file) + +-- wz1000 offered +-- the idea from https://gitlab.haskell.org/ghc/haddock/-/blob/b0b0e0366457c9aefebcc94df74e5de4d00e17b7/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs#L107 +-- optimize version of looking for which types are functions without unfolding the whole type +recoverFunMaskArray :: + -- | flat types + A.Array TypeIndex HieTypeFlat -> + -- | array of bool indicating whether the type is a function + A.Array TypeIndex Bool +recoverFunMaskArray flattened = unflattened + where + -- The recursion in 'unflattened' is crucial - it's what gives us sharing + -- function indicator check. + unflattened :: A.Array TypeIndex Bool + unflattened = fmap (go . fmap (unflattened A.!)) flattened + + -- Unfold an 'HieType' whose sub-terms have already been unfolded + go :: HieType Bool -> Bool + go (HTyVarTy _name) = False + go (HAppTy _f _x) = False + go (HLitTy _lit) = False + go (HForAllTy ((_n, _k), _af) b) = b + go (HFunTy {}) = True + go (HQualTy _constraint b) = b + go (HCastTy b) = b + go HCoercionTy = False + -- we have no enough information to expand the type synonym + go (HTyConApp _ _) = False + +typeSemantic :: HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType +typeSemantic kind t = case kind of + HieFreshFun -> if isFunType t then Just TFunction else Nothing + HieFromDiskFun arr -> if arr A.! t then Just TFunction else Nothing + +-- * 3. Mapping from hieAst ContextInfo to haskell semantic token type. + +infoTokenType :: ContextInfo -> Maybe HsSemanticTokenType +infoTokenType x = case x of + Use -> Nothing + MatchBind -> Nothing + IEThing _ -> Nothing + TyDecl -> Nothing -- type signature + ValBind RegularBind _ _ -> Just TVariable + ValBind InstanceBind _ _ -> Just TClassMethod + PatternBind {} -> Just TVariable + ClassTyDecl _ -> Just TClassMethod + TyVarBind _ _ -> Just TTypeVariable + RecField _ _ -> Just TRecordField + -- data constructor, type constructor, type synonym, type family + Decl ClassDec _ -> Just TClass + Decl DataDec _ -> Just TTypeConstructor + Decl ConDec _ -> Just TDataConstructor + Decl SynDec _ -> Just TTypeSynonym + Decl FamDec _ -> Just TTypeFamily + -- instance dec is class method + Decl InstDec _ -> Just TClassMethod + Decl PatSynDec _ -> Just TPatternSynonym + EvidenceVarUse -> Nothing + EvidenceVarBind {} -> Nothing + +-- * 4. Mapping from LSP tokens to SemanticTokenOriginal. + +-- | recoverSemanticTokens +-- for debug and test. +-- this function is used to recover the original tokens(with token in haskell token type zoon) +-- from the lsp semantic tokens(with token in lsp token type zoon) +-- the `SemanticTokensConfig` used should be a map with bijection property +recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType] +recoverSemanticTokens config v s = do + tks <- recoverLspSemanticTokens v s + return $ map (lspTokenHsToken config) tks + +-- | lspTokenHsToken +-- for debug and test. +-- use the `SemanticTokensConfig` to convert lsp token type to haskell token type +-- the `SemanticTokensConfig` used should be a map with bijection property +lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType +lspTokenHsToken config (SemanticTokenOriginal tokenType location name) = + case lspTokenTypeHsTokenType config tokenType of + Just t -> SemanticTokenOriginal t location name + Nothing -> error "recoverSemanticTokens: unknown lsp token type" + +-- | recoverLspSemanticTokens +-- for debug and test. +-- this function is used to recover the original tokens(with token in standard lsp token type zoon) +-- from the lsp semantic tokens(with token in lsp token type zoon) +recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes] +recoverLspSemanticTokens vsf (SemanticTokens _ xs) = do + tokens <- dataActualToken xs + return $ mapMaybe (tokenOrigin sourceCode) tokens + where + sourceCode = unpack $ virtualFileText vsf + tokenOrigin :: [Char] -> SemanticTokenAbsolute -> Maybe (SemanticTokenOriginal SemanticTokenTypes) + tokenOrigin sourceCode' (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) = do + -- convert back to count from 1 + let range = mkRange line startChar len + CodePointRange (CodePointPosition x y) (CodePointPosition _ y1) <- rangeToCodePointRange vsf range + let line' = x + let startChar' = y + let len' = y1 - y + let tLine = lines sourceCode' !? fromIntegral line' + let name = maybe "no source" (take (fromIntegral len') . drop (fromIntegral startChar')) tLine + return $ SemanticTokenOriginal tokenType (Loc (line' + 1) (startChar' + 1) len') name + + dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute] + dataActualToken dt = + maybe decodeError (Right . absolutizeTokens) $ + mapM fromTuple (chunksOf 5 $ map fromIntegral dt) + where + decodeError = Left "recoverSemanticTokenRelative: wrong token data" + fromTuple [a, b, c, d, _] = SemanticTokenRelative a b c <$> fromInt (fromIntegral d) <*> return [] + fromTuple _ = Nothing + + + -- legends :: SemanticTokensLegend + fromInt :: Int -> Maybe SemanticTokenTypes + fromInt i = Set.toAscList knownValues !? i + +-- Note [Semantic information from Multiple Sources] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We group Name into 2 categories since the information source is different: +-- 1. Locally defined Name +-- Information source is current module's HieAst, +-- Either from ContextInfo(all except differing function and none-function) +-- or from Hie Type(Differing Function and Non-function Variable) +-- 2. Imported Name +-- Information source is `TyThing` for the `Name`, looked up in `HscEnv`(with all imported things loaded). +-- `TyThing` is information rich, since it is used to represent the things that a name can refer to in ghc. +-- The reason why we need special handling for imported name is that +-- Up to 9.8 +-- 1. For Hie Type, IfaceTyCon in hie type does not contain enough information to distinguish class, type syn, type family etc.. +-- 2. Most imported name is only annotated as [Use] in the ContextInfo from hie. +-- 3. `namespace` in `Name` is limited, we can only classify `VarName, FldName, DataName, TvNamem, TcClsName`. +-- 4. WiredIn `Name` have `TyThing` attached, but not many are WiredIn names. diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -0,0 +1,92 @@ +-- | +-- The query module is used to query the semantic tokens from the AST +module Ide.Plugin.SemanticTokens.Query where + +import Control.Applicative ((<|>)) +import Data.Foldable (fold) +import qualified Data.Map.Strict as M +import Data.Maybe (listToMaybe, mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import Development.IDE.Core.PositionMapping (PositionMapping, + toCurrentRange) +import Development.IDE.GHC.Compat +import Ide.Plugin.SemanticTokens.Mappings +import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, + HsSemanticTokenType (TModule), + RangeSemanticTokenTypeList, + SemanticTokenId, + SemanticTokensConfig) +import Language.LSP.Protocol.Types (Position (Position), + Range (Range), + SemanticTokenAbsolute (SemanticTokenAbsolute), + SemanticTokens (SemanticTokens), + SemanticTokensDelta (SemanticTokensDelta), + defaultSemanticTokensLegend, + makeSemanticTokens, + makeSemanticTokensDelta) +import Prelude hiding (length, span) + +--------------------------------------------------------- + +-- * extract semantic + +--------------------------------------------------------- + +idSemantic :: forall a. NameEnv TyThing -> HieFunMaskKind a -> RefMap a -> Identifier -> Maybe HsSemanticTokenType +idSemantic _ _ _ (Left _) = Just TModule +idSemantic tyThingMap hieKind rm (Right n) = + nameSemanticFromHie hieKind rm n -- local name + <|> (lookupNameEnv tyThingMap n >>= tyThingSemantic) -- global name + + +--------------------------------------------------------- + +-- * extract semantic from HieAst for local variables + +--------------------------------------------------------- + +nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType +nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n) + where + idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType + idSemanticFromRefMap rm' name' = do + spanInfos <- M.lookup name' rm' + let typeTokenType = foldMap (typeSemantic hieKind) $ listToMaybe $ mapMaybe (identType . snd) spanInfos + contextInfoTokenType <- foldMap (contextInfosMaybeTokenType . identInfo . snd) spanInfos + fold [typeTokenType, Just contextInfoTokenType, nameInfixOperator n] + + contextInfosMaybeTokenType :: Set.Set ContextInfo -> Maybe HsSemanticTokenType + contextInfosMaybeTokenType details = foldMap infoTokenType (Set.toList details) + + +------------------------------------------------- + +-- * extract lsp semantic tokens from RangeSemanticTokenTypeList + +------------------------------------------------- + +rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens +rangeSemanticsSemanticTokens sid stc mapping = + makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) + where + toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute + toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType = + let len = endColumn - startColumn + in SemanticTokenAbsolute + (fromIntegral startLine) + (fromIntegral startColumn) + (fromIntegral len) + (toLspTokenType stc tokenType) + [] + +makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokensWithId sid tokens = do + (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens + return $ SemanticTokens sid tokens + +makeSemanticTokensDeltaWithId :: Maybe SemanticTokenId -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta +makeSemanticTokensDeltaWithId sid previousTokens currentTokens = + let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens + in SemanticTokensDelta sid stEdits + diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.SemanticTokens.SemanticConfig where + +import Data.Char (toLower) +import Data.Default (def) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (Action, usePropertyAction) +import GHC.TypeLits (KnownSymbol) +import Ide.Plugin.Properties (KeyNameProxy, NotElem, + Properties, + PropertyKey (type PropertyKey), + PropertyType (type TEnum), + defineEnumProperty, + emptyProperties) +import Ide.Plugin.SemanticTokens.Types +import Ide.Types (PluginId) +import Language.Haskell.TH +import Language.LSP.Protocol.Types (LspEnum (..), + SemanticTokenTypes) + +docName :: HsSemanticTokenType -> T.Text +docName tt = case tt of + TVariable -> "variables" + TFunction -> "functions" + TDataConstructor -> "data constructors" + TTypeVariable -> "type variables" + TClassMethod -> "typeclass methods" + TPatternSynonym -> "pattern synonyms" + TTypeConstructor -> "type constructors" + TClass -> "typeclasses" + TTypeSynonym -> "type synonyms" + TTypeFamily -> "type families" + TRecordField -> "record fields" + TModule -> "modules" + TOperator -> "operators" + +toConfigName :: String -> String +toConfigName = ("st" <>) + +type LspTokenTypeDescriptions = [(SemanticTokenTypes, T.Text)] + +lspTokenTypeDescriptions :: LspTokenTypeDescriptions +lspTokenTypeDescriptions = + map + ( \x -> + (x, "LSP Semantic Token Type: " <> toEnumBaseType x) + ) + $ S.toList knownValues + +allHsTokenTypes :: [HsSemanticTokenType] +allHsTokenTypes = enumFrom minBound + +lowerFirst :: String -> String +lowerFirst [] = [] +lowerFirst (x : xs) = toLower x : xs + +allHsTokenNameStrings :: [String] +allHsTokenNameStrings = map (drop 1 . show) allHsTokenTypes + +defineSemanticProperty :: + (NotElem s r, KnownSymbol s) => + (KeyNameProxy s, Text, SemanticTokenTypes) -> + Properties r -> + Properties ('PropertyKey s (TEnum SemanticTokenTypes) : r) +defineSemanticProperty (lb, tokenType, st) = + defineEnumProperty + lb + tokenType + lspTokenTypeDescriptions + st + +semanticDef :: SemanticTokensConfig +semanticDef = def + +-- | it produces the following functions: +-- semanticConfigProperties :: Properties '[ +-- 'PropertyKey "Variable" ('TEnum SemanticTokenTypes), +-- ... +-- ] +-- useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig +mkSemanticConfigFunctions :: Q [Dec] +mkSemanticConfigFunctions = do + let pid = mkName "pid" + let semanticConfigPropertiesName = mkName "semanticConfigProperties" + let useSemanticConfigActionName = mkName "useSemanticConfigAction" + let allLabelStrs = map ((<> "Token") . lowerFirst) allHsTokenNameStrings + allLabels = map (LabelE . (<> "Token") . lowerFirst) allHsTokenNameStrings + allFieldsNames = map (mkName . toConfigName) allHsTokenNameStrings + allVariableNames = map (mkName . ("_variable_" <>) . toConfigName) allHsTokenNameStrings + -- <- useSemanticConfigAction label pid config + mkGetProperty (variable, label) = + BindS + (VarP variable) + (AppE (VarE 'usePropertyAction) label `AppE` VarE pid `AppE` VarE semanticConfigPropertiesName) + getProperties = zipWith (curry mkGetProperty) allVariableNames allLabels + recordUpdate = + RecUpdE (VarE 'semanticDef) $ + zipWith (\fieldName variableName -> (fieldName, VarE variableName)) allFieldsNames allVariableNames + -- get and then update record + bb = DoE Nothing $ getProperties ++ [NoBindS $ AppE (VarE 'return) recordUpdate] + let useSemanticConfigAction = FunD useSemanticConfigActionName [Clause [VarP pid] (NormalB bb) []] + let useSemanticConfigActionSig = SigD useSemanticConfigActionName (ArrowT `AppT` ConT ''PluginId `AppT` (ConT ''Action `AppT` ConT ''SemanticTokensConfig)) + + -- SemanticConfigProperties + nameAndDescList <- + mapM + ( \(lb, x) -> do + desc <- [|"LSP semantic token type to use for " <> docName x|] + lspToken <- [|toLspTokenType def x|] + return $ TupE [Just lb, Just desc, Just lspToken] + ) + $ zip allLabels allHsTokenTypes + let body = foldr (AppE . AppE (VarE 'defineSemanticProperty)) (VarE 'emptyProperties) nameAndDescList + let propertiesType = + foldr + ( \la -> + AppT + ( PromotedConsT + `AppT` (AppT (ConT 'PropertyKey) (LitT (StrTyLit la)) `AppT` AppT (ConT 'TEnum) (ConT ''SemanticTokenTypes)) + ) + ) + PromotedNilT + allLabelStrs + let semanticConfigProperties = FunD semanticConfigPropertiesName [Clause [] (NormalB body) []] + let semanticConfigPropertiesSig = SigD semanticConfigPropertiesName (AppT (ConT ''Properties) propertiesType) + return [semanticConfigPropertiesSig, semanticConfigProperties, useSemanticConfigActionSig, useSemanticConfigAction] diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where + +import Control.Lens (Identity (runIdentity)) +import Control.Monad (foldM, guard) +import Control.Monad.State.Strict (MonadState (get), + MonadTrans (lift), + evalStateT, modify, put) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Data.Char (isAlphaNum) +import Data.DList (DList) +import qualified Data.DList as DL +import qualified Data.Map.Strict as M +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Rope as Char +import qualified Data.Text.Utf16.Rope as Utf16 +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (realSrcSpanToCodePointRange) +import Ide.Plugin.SemanticTokens.Types (HsSemanticTokenType (TModule), + RangeHsSemanticTokenTypes (..)) +import Language.LSP.Protocol.Types (Position (Position), + Range (Range), UInt, mkRange) +import Language.LSP.VFS hiding (line) +import Prelude hiding (length, span) + +type Tokenizer m a = StateT PTokenState m a +type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType + + +data PTokenState = PTokenState + { + rope :: !Rope -- the remains of rope we are working on + , cursor :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position + , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 + } + +data SplitResult + = NoSplit (Text, Range) -- does not need to split, token text, token range + | Split (Text, Range, Range) -- token text, prefix range(module range), token range + deriving (Show) + +getSplitTokenText :: SplitResult -> Text +getSplitTokenText (NoSplit (t, _)) = t +getSplitTokenText (Split (t, _, _)) = t + + +mkPTokenState :: VirtualFile -> PTokenState +mkPTokenState vf = + PTokenState + { + rope = vf._file_text, + cursor = Char.Position 0 0, + columnsInUtf16 = 0 + } + +-- lift a Tokenizer Maybe a to Tokenizer m a, +-- if the Maybe is Nothing, do nothing, recover the state, and return the mempty value +-- if the Maybe is Just x, do the action, and keep the state, and return x +liftMaybeM :: (Monad m, Monoid a) => Tokenizer Maybe a -> Tokenizer m a +liftMaybeM p = do + st <- get + maybe (return mempty) (\(ans, st') -> put st' >> return ans) $ runStateT p st + +foldMapM :: (Monad m, Monoid b, Foldable t) => (a -> m b) -> t a -> m b +foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta + +computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes +computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = + RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf) +-- | foldAst +-- visit every leaf node in the ast in depth first order +foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) +foldAst lookupHsTokenType ast = if null (nodeChildren ast) + then liftMaybeM (visitLeafIds lookupHsTokenType ast) + else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast + +visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)) +visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do + let span = nodeSpan leaf + (ran, token) <- focusTokenAt leaf + -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly + -- we do not need to recover the cursor state, even if the following computation failed + liftMaybeM $ do + -- only handle the leaf node with single column token + guard $ srcSpanStartLine span == srcSpanEndLine span + splitResult <- lift $ splitRangeByText token ran + foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf + where + combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType)) + combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = + case (maybeTokenType, ranSplit) of + (Nothing, _) -> return mempty + (Just TModule, _) -> return $ DL.singleton (ran, TModule) + (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType) + (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)] + where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) + + getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType + getIdentifier lookupHsTokenType ranSplit idt = do + case idt of + Left _moduleName -> Just TModule + Right name -> do + occStr <- T.pack <$> case (occNameString . nameOccName) name of + -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-} + '$' : 's' : 'e' : 'l' : ':' : xs -> Just $ takeWhile (/= ':') xs + -- other generated names that should not be visible + '$' : c : _ | isAlphaNum c -> Nothing + c : ':' : _ | isAlphaNum c -> Nothing + ns -> Just ns + guard $ getSplitTokenText ranSplit == occStr + lookupHsTokenType idt + + +focusTokenAt :: + -- | leaf node we want to focus on + HieAST a -> + -- | (token, remains) + Tokenizer Maybe (Range, Text) +focusTokenAt leaf = do + PTokenState{cursor, rope, columnsInUtf16} <- get + let span = nodeSpan leaf + let (tokenStartPos, tokenEndPos) = srcSpanCharPositions span + -- tokenStartOff: the offset position of the token start position to the cursor position + tokenStartOff <- lift $ tokenStartPos `sub` cursor + -- tokenOff: the offset position of the token end position to the token start position + tokenOff <- lift $ tokenEndPos `sub` tokenStartPos + (gap, tokenStartRope) <- lift $ charSplitAtPositionMaybe tokenStartOff rope + (token, remains) <- lift $ charSplitAtPositionMaybe tokenOff tokenStartRope + -- ncs: token start column in utf16 + let ncs = newColumn columnsInUtf16 gap + -- nce: token end column in utf16 + let nce = newColumn ncs token + -- compute the new range for utf16, tuning the columns is enough + let ran = codePointRangeToRangeWith ncs nce $ realSrcSpanToCodePointRange span + modify $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos} + return (ran, token) + where + srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position) + srcSpanCharPositions real = + ( realSrcLocRopePosition $ realSrcSpanStart real, + realSrcLocRopePosition $ realSrcSpanEnd real + ) + charSplitAtPositionMaybe :: Char.Position -> Rope -> Maybe (Text, Rope) + charSplitAtPositionMaybe tokenOff rpe = do + let (prefix, suffix) = Rope.charSplitAtPosition tokenOff rpe + guard $ Rope.charLengthAsPosition prefix == tokenOff + return (Rope.toText prefix, suffix) + sub :: Char.Position -> Char.Position -> Maybe Char.Position + sub (Char.Position l1 c1) (Char.Position l2 c2) + | l1 == l2 && c1 >= c2 = Just $ Char.Position 0 (c1 - c2) + | l1 > l2 = Just $ Char.Position (l1 - l2) c1 + | otherwise = Nothing + realSrcLocRopePosition :: RealSrcLoc -> Char.Position + realSrcLocRopePosition real = Char.Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) + -- | newColumn + -- rope do not treat single \n in our favor + -- for example, the row length of "123\n" and "123" are both 1 + -- we are forced to use text to compute new column + newColumn :: UInt -> Text -> UInt + newColumn n rp = case T.breakOnEnd "\n" rp of + ("", nEnd) -> n + utf16Length nEnd + (_, nEnd) -> utf16Length nEnd + codePointRangeToRangeWith :: UInt -> UInt -> CodePointRange -> Range + codePointRangeToRangeWith newStartCol newEndCol (CodePointRange (CodePointPosition startLine _) (CodePointPosition endLine _)) = + Range (Position startLine newStartCol) (Position endLine newEndCol) + +-- | splitRangeByText +-- split a qualified identifier into module name and identifier and/or strip the (), `` +-- for `ModuleA.b`, break it into `ModuleA.` and `b` +-- for `(b)`, strip `()`, and get `b` +-- for `(ModuleA.b)`, strip `()` and break it into `ModuleA.` and `b` +splitRangeByText :: Text -> Range -> Maybe SplitResult +splitRangeByText tk ran = do + let (ran', tk') = case T.uncons tk of + Just ('(', xs) -> (subOneRange ran, T.takeWhile (/= ')') xs) + Just ('`', xs) -> (subOneRange ran, T.takeWhile (/= '`') xs) + _ -> (ran, tk) + let (prefix, tk'') = T.breakOnEnd "." tk' + splitRange tk'' (utf16PositionPosition $ Rope.utf16LengthAsPosition $ Rope.fromText prefix) ran' + where + splitRange :: Text -> Position -> Range -> Maybe SplitResult + splitRange tx (Position l c) r@(Range (Position l1 c1) (Position l2 c2)) + | l1 + l > l2 || (l1 + l == l2 && c > c2) = Nothing -- out of range + | l==0 && c==0 = Just $ NoSplit (tx, r) + | otherwise = let c' = if l <= 0 then c1+c else c + in Just $ Split (tx, mkRange l1 c1 (l1 + l) c', mkRange (l1 + l) c' l2 c2) + subOneRange :: Range -> Range + subOneRange (Range (Position l1 c1) (Position l2 c2)) = Range (Position l1 (c1 + 1)) (Position l2 (c2 - 1)) + utf16PositionPosition :: Utf16.Position -> Position + utf16PositionPosition (Utf16.Position l c) = Position (fromIntegral l) (fromIntegral c) + + +utf16Length :: Integral i => Text -> i +utf16Length = fromIntegral . Utf16.length . Utf16.fromText diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.SemanticTokens.Types where + +import Control.DeepSeq (NFData (rnf), rwhnf) +import qualified Data.Array as A +import Data.Default (Default (def)) +import Data.Generics (Typeable) +import Development.IDE (Pretty (pretty), RuleResult) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (loc) +import Development.IDE.Graph.Classes (Hashable) +import GHC.Generics (Generic) +import Language.LSP.Protocol.Types +-- import template haskell +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) + + +-- !!!! order of declarations matters deriving enum and ord +-- since token may come from different source and we want to keep the most specific one +-- and we might want to merge them. +data HsSemanticTokenType + = TVariable -- none function variable + | TFunction -- function + | TDataConstructor -- Data constructor + | TTypeVariable -- Type variable + | TClassMethod -- Class method + | TPatternSynonym -- Pattern synonym + | TTypeConstructor -- Type (Type constructor) + | TClass -- Type class + | TTypeSynonym -- Type synonym + | TTypeFamily -- type family + | TRecordField -- from match bind + | TOperator-- operator + | TModule -- module name + deriving (Eq, Ord, Show, Enum, Bounded, Generic, Lift) + +-- type SemanticTokensConfig = SemanticTokensConfig_ Identity +instance Default SemanticTokensConfig where + def = STC + { stFunction = SemanticTokenTypes_Function + , stVariable = SemanticTokenTypes_Variable + , stDataConstructor = SemanticTokenTypes_EnumMember + , stTypeVariable = SemanticTokenTypes_TypeParameter + , stClassMethod = SemanticTokenTypes_Method + -- pattern syn is like a limited version of macro of constructing a term + , stPatternSynonym = SemanticTokenTypes_Macro + -- normal data type is a tagged union type look like enum type + -- and a record is a product type like struct + -- but we don't distinguish them yet + , stTypeConstructor = SemanticTokenTypes_Enum + , stClass = SemanticTokenTypes_Class + , stTypeSynonym = SemanticTokenTypes_Type + , stTypeFamily = SemanticTokenTypes_Interface + , stRecordField = SemanticTokenTypes_Property + , stModule = SemanticTokenTypes_Namespace + , stOperator = SemanticTokenTypes_Operator + } +-- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin. +-- it contains map between the hs semantic token type and default token type. +data SemanticTokensConfig = STC + { stFunction :: !SemanticTokenTypes + , stVariable :: !SemanticTokenTypes + , stDataConstructor :: !SemanticTokenTypes + , stTypeVariable :: !SemanticTokenTypes + , stClassMethod :: !SemanticTokenTypes + , stPatternSynonym :: !SemanticTokenTypes + , stTypeConstructor :: !SemanticTokenTypes + , stClass :: !SemanticTokenTypes + , stTypeSynonym :: !SemanticTokenTypes + , stTypeFamily :: !SemanticTokenTypes + , stRecordField :: !SemanticTokenTypes + , stModule :: !SemanticTokenTypes + , stOperator :: !SemanticTokenTypes + } deriving (Generic, Show) + + +instance Semigroup HsSemanticTokenType where + -- one in higher enum is more specific + a <> b = max a b + +data SemanticTokenOriginal tokenType = SemanticTokenOriginal + { _tokenType :: tokenType, + _loc :: Loc, + _name :: String + } + deriving (Eq, Ord) + +-- +instance (Show tokenType) => Show (SemanticTokenOriginal tokenType) where + show (SemanticTokenOriginal tk loc name) = show loc <> " " <> show tk <> " " <> show name + +data Loc = Loc + { _line :: UInt, + _startChar :: UInt, + _len :: UInt + } + deriving (Eq, Ord) + +instance Show Loc where + show (Loc line startChar len) = show line <> ":" <> show startChar <> "-" <> show (startChar + len) + +data GetSemanticTokens = GetSemanticTokens + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetSemanticTokens + +instance NFData GetSemanticTokens + +type RangeSemanticTokenTypeList = [(Range, HsSemanticTokenType)] + +newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticList :: RangeSemanticTokenTypeList} + +instance NFData RangeHsSemanticTokenTypes where + rnf :: RangeHsSemanticTokenTypes -> () + rnf (RangeHsSemanticTokenTypes a) = rwhnf a + +instance Show RangeHsSemanticTokenTypes where + show (RangeHsSemanticTokenTypes xs) = unlines $ map showRangeToken xs + +showRangeToken :: (Range, HsSemanticTokenType) -> String +showRangeToken (ran, tk) = showRange ran <> " " <> show tk +showRange :: Range -> String +showRange (Range (Position l1 c1) (Position l2 c2)) = show l1 <> ":" <> show c1 <> "-" <> show l2 <> ":" <> show c2 + +type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes + +data HieFunMaskKind kind where + HieFreshFun :: HieFunMaskKind Type + HieFromDiskFun :: A.Array TypeIndex Bool -> HieFunMaskKind TypeIndex + +data SemanticLog + = LogShake Shake.Log + | LogNoAST FilePath + | LogConfig SemanticTokensConfig + | LogMsg String + | LogNoVF + | LogSemanticTokensDeltaMisMatch Text (Maybe Text) + deriving (Show) + +instance Pretty SemanticLog where + pretty theLog = case theLog of + LogShake shakeLog -> pretty shakeLog + LogNoAST path -> "no HieAst exist for file" <> pretty path + LogNoVF -> "no VirtualSourceFile exist for file" + LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config) + LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg + LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache + -> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest + <> " previousIdFromCache: " <> pretty previousIdFromCache + + +type SemanticTokenId = Text diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + + +module Ide.Plugin.SemanticTokens.Utils where + +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (unpack) +import qualified Data.Map.Strict as Map +import Development.IDE (Position (..), Range (..)) +import Development.IDE.GHC.Compat +import Prelude hiding (length, span) + +deriving instance Show DeclType +deriving instance Show BindType +deriving instance Show RecFieldContext + +instance Show ContextInfo where + show x = case x of + Use -> "Use" + MatchBind -> "MatchBind" + IEThing _ -> "IEThing IEType" -- imported + TyDecl -> "TyDecl" + ValBind bt _ sp -> "ValBind of " <> show bt <> show sp + PatternBind {} -> "PatternBind" + ClassTyDecl _ -> "ClassTyDecl" + Decl d _ -> "Decl of " <> show d + TyVarBind _ _ -> "TyVarBind" + RecField c _ -> "RecField of " <> show c + EvidenceVarBind {} -> "EvidenceVarBind" + EvidenceVarUse -> "EvidenceVarUse" + +showCompactRealSrc :: RealSrcSpan -> String +showCompactRealSrc x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x) + +-- type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] +showRefMap :: RefMap a -> String +showRefMap m = unlines + [ + showIdentifier idn ++ ":" + ++ "\n" ++ unlines [showSDocUnsafe (ppr span) ++ "\n" ++ showIdentifierDetails v | (span, v) <- spans] + | (idn, spans) <- Map.toList m] + +showIdentifierDetails :: IdentifierDetails a -> String +showIdentifierDetails x = show $ identInfo x + +showIdentifier :: Identifier -> String +showIdentifier (Left x) = showSDocUnsafe (ppr x) +showIdentifier (Right x) = nameStableString x + +showLocatedNames :: [LIdP GhcRn] -> String +showLocatedNames xs = unlines + [ showSDocUnsafe (ppr locName) ++ " " ++ show (getLoc locName) + | locName <- xs] + +showClearName :: Name -> String +showClearName name = occNameString (occName name) <> ":" <> showSDocUnsafe (ppr name) <> ":" <> showNameType name + +showName :: Name -> String +showName name = showSDocUnsafe (ppr name) <> ":" <> showNameType name + +showNameType :: Name -> String +showNameType name + | isWiredInName name = "WiredInName" + | isSystemName name = "SystemName" + | isInternalName name = "InternalName" + | isExternalName name = "ExternalName" + | otherwise = "UnknownName" + +bytestringString :: ByteString -> String +bytestringString = map (toEnum . fromEnum) . unpack + +spanNamesString :: [(Span, Name)] -> String +spanNamesString xs = unlines + [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name) + | (span, name) <- xs] + +nameTypesString :: [(Name, Type)] -> String +nameTypesString xs = unlines + [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name) + | (span, name) <- xs] + + +showSpan :: RealSrcSpan -> String +showSpan x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x) + + +-- rangeToCodePointRange +mkRange :: (Integral a1, Integral a2) => a1 -> a2 -> a2 -> Range +mkRange startLine startCol len = + Range (Position (fromIntegral startLine) (fromIntegral startCol)) (Position (fromIntegral startLine) (fromIntegral $ startCol + len)) + + +rangeShortStr :: Range -> String +rangeShortStr (Range (Position startLine startColumn) (Position endLine endColumn)) = + show startLine <> ":" <> show startColumn <> "-" <> show endLine <> ":" <> show endColumn + diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Lens ((^.), (^?)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (KeyValue (..), Object) +import qualified Data.Aeson.KeyMap as KV +import Data.Default +import Data.Functor (void) +import Data.Map.Strict as Map hiding (map) +import Data.String (fromString) +import Data.Text hiding (length, map, + unlines) +import qualified Data.Text as Text +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE (Pretty) + +import Data.Row ((.==)) +import Data.Row.Records ((.+)) +import Development.IDE.GHC.Compat (GhcVersion (..), + ghcVersion) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import Development.IDE.Test (waitForBuildQueue) +import Ide.Plugin.SemanticTokens +import Ide.Plugin.SemanticTokens.Mappings +import Ide.Plugin.SemanticTokens.Types +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types +import Language.LSP.Test (Session, + SessionConfig (ignoreConfigurationRequests), + openDoc, request) +import qualified Language.LSP.Test as Test +import Language.LSP.VFS (VirtualFile (..)) +import System.FilePath +import Test.Hls (HasCallStack, + PluginTestDescriptor, + SMethod (SMethod_TextDocumentSemanticTokensFullDelta), + TestName, TestTree, + changeDoc, + defaultTestRunner, + documentContents, fullCaps, + goldenGitDiff, + mkPluginTestDescriptor, + pluginTestRecorder, + runSessionWithServerInTmpDir, + runSessionWithServerInTmpDir', + testCase, testGroup, + waitForAction, (@?=)) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) + +testDataDir :: FilePath +testDataDir = "plugins" "hls-semantic-tokens-plugin" "test" "testdata" + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog +semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor "SemanticTokens" + where + enabledSemanticDescriptor recorder plId = + let semanticDescriptor = Ide.Plugin.SemanticTokens.descriptor recorder plId + in semanticDescriptor + { pluginConfigDescriptor = + (pluginConfigDescriptor semanticDescriptor) + { configInitialGenericConfig = + (configInitialGenericConfig (pluginConfigDescriptor semanticDescriptor)) + { plcGlobalOn = True + } + } + } + +goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree +goldenWithHaskellAndCapsOutPut config plugin title tree path desc act = + goldenGitDiff title (FS.vftOriginalRoot tree path <.> desc) $ + runSessionWithServerInTmpDir config plugin tree $ + fromString <$> do + doc <- openDoc (path <.> "hs") "haskell" + void waitForBuildQueue + act doc + +goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree +goldenWithSemanticTokensWithDefaultConfig title path = + goldenWithHaskellAndCapsOutPut + def + semanticTokensPlugin + title + (mkFs $ FS.directProject (path <.> "hs")) + path + "expected" + (docSemanticTokensString def) + +docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String +docSemanticTokensString cf doc = do + xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc + return $ unlines . map show $ xs + +docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] +docLspSemanticTokensString doc = do + res <- Test.getSemanticTokens doc + textContent <- documentContents doc + let vfs = VirtualFile 0 0 (Rope.fromText textContent) + case res ^? Language.LSP.Protocol.Types._L of + Just tokens -> do + either (error . show) pure $ recoverLspSemanticTokens vfs tokens + _noTokens -> error "No tokens found" + + +-- | Pass a param and return the response from `semanticTokensFull` +-- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ +getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null)) +getSemanticTokensFullDelta doc lastResultId = do + let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId + rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params + case rsp ^. L.result of + Right x -> return x + _ -> error "No tokens found" + + +semanticTokensClassTests :: TestTree +semanticTokensClassTests = + testGroup + "type class" + [ goldenWithSemanticTokensWithDefaultConfig "golden type class" "TClass", + goldenWithSemanticTokensWithDefaultConfig "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind", + goldenWithSemanticTokensWithDefaultConfig "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse", + goldenWithSemanticTokensWithDefaultConfig "imported deriving" "TClassImportedDeriving" + ] + +semanticTokensValuePatternTests :: TestTree +semanticTokensValuePatternTests = + testGroup + "value and patterns " + [ goldenWithSemanticTokensWithDefaultConfig "value bind" "TValBind", + goldenWithSemanticTokensWithDefaultConfig "pattern match" "TPatternMatch", + goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternbind" + ] + +mkSemanticConfig :: Object -> Config +mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)} + where + conf = def{plcConfig = setting } + + + +directFile :: FilePath -> Text -> [FS.FileTree] +directFile fp content = + [ FS.directCradle [Text.pack fp] + , file fp (text content) + ] + +semanticTokensConfigTest :: TestTree +semanticTokensConfigTest = testGroup "semantic token config test" [ + testCase "function to variable" $ do + let content = Text.unlines ["module Hello where", "go _ = 1"] + let fs = mkFs $ directFile "Hello.hs" content + let funcVar = KV.fromList ["functionToken" .= var] + var :: String + var = "variable" + do + recorder <- pluginTestRecorder + Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder) + (mkSemanticConfig funcVar) + def {ignoreConfigurationRequests = False} + fullCaps + fs $ do + -- modifySemantic funcVar + void waitForBuildQueue + doc <- openDoc "Hello.hs" "haskell" + void waitForBuildQueue + result1 <- docLspSemanticTokensString doc + liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" + ] + +semanticTokensFullDeltaTests :: TestTree +semanticTokensFullDeltaTests = + testGroup "semanticTokensFullDeltaTests" $ + [ testCase "null delta since unchanged" $ do + let file1 = "TModuleA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [])) + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + + , testCase "add tokens" $ do + let file1 = "TModuleA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])])) + -- r c l t m + -- where r = row, c = column, l = length, t = token, m = modifier + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 4 0) (Position 4 6) + .+ #rangeLength .== Nothing + .+ #text .== "foo = 1" + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + + , testCase "remove tokens" $ do + let file1 = "TModuleA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) + -- delete all tokens + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 2 0) (Position 2 28) + .+ #rangeLength .== Nothing + .+ #text .== Text.replicate 28 " " + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + ] + +semanticTokensTests :: TestTree +semanticTokensTests = + testGroup "other semantic Token test" $ + [ testCase "module import test" $ do + let file1 = "TModuleA.hs" + let file2 = "TModuleB.hs" + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1, file2]) $ do + doc1 <- openDoc file1 "haskell" + doc2 <- openDoc file2 "haskell" + check1 <- waitForAction "TypeCheck" doc1 + check2 <- waitForAction "TypeCheck" doc2 + case check1 of + Right (WaitForIdeRuleResult _) -> return () + Left _ -> error "TypeCheck1 failed" + case check2 of + Right (WaitForIdeRuleResult _) -> return () + Left _ -> error "TypeCheck2 failed" + + result <- docSemanticTokensString def doc2 + let expect = unlines [ + "3:8-16 TModule \"TModuleA\"" + , "4:18-26 TModule \"TModuleA\"" + , "6:1-3 TVariable \"go\"" + , "6:6-10 TDataConstructor \"Game\"" + , "8:1-5 TVariable \"a\\66560bb\"" + , "8:8-17 TModule \"TModuleA.\"" + , "8:17-20 TRecordField \"a\\66560b\"" + , "8:21-23 TVariable \"go\"" + ] + liftIO $ result @?= expect, + goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1", + goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym", + goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily", + goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax", + goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName" + ] + -- not supported in ghc92 + ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92] + +semanticTokensDataTypeTests :: TestTree +semanticTokensDataTypeTests = + testGroup + "get semantic Tokens" + [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType", + goldenWithSemanticTokensWithDefaultConfig "record" "TRecord", + goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields", + goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported", + goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily", + goldenWithSemanticTokensWithDefaultConfig "GADT" "TGADT" + ] + +semanticTokensFunctionTests :: TestTree +semanticTokensFunctionTests = + testGroup + "get semantic of functions" + [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction", + goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal", + goldenWithSemanticTokensWithDefaultConfig "functions under type synonym" "TFunctionUnderTypeSynonym", + goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet", + goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint", + goldenWithSemanticTokensWithDefaultConfig "TOperator" "TOperator" + ] + +main :: IO () +main = + defaultTestRunner $ + testGroup + "Semantic tokens" + [ semanticTokensTests, + semanticTokensClassTests, + semanticTokensDataTypeTests, + semanticTokensValuePatternTests, + semanticTokensFunctionTests, + semanticTokensConfigTest, + semanticTokensFullDeltaTests + ] diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected @@ -0,0 +1,81 @@ +9:6-9 TTypeConstructor "Foo" +9:12-15 TDataConstructor "Foo" +9:18-21 TRecordField "foo" +9:25-28 TTypeConstructor "Int" +11:7-10 TClass "Boo" +11:11-12 TTypeVariable "a" +12:3-6 TClassMethod "boo" +12:10-11 TTypeVariable "a" +12:15-16 TTypeVariable "a" +14:10-13 TClass "Boo" +14:14-17 TTypeConstructor "Int" +15:5-8 TClassMethod "boo" +15:9-10 TVariable "x" +15:13-14 TVariable "x" +15:15-16 TOperator "+" +17:6-8 TTypeConstructor "Dd" +17:11-13 TDataConstructor "Dd" +17:14-17 TTypeConstructor "Int" +19:9-12 TPatternSynonym "One" +19:15-18 TDataConstructor "Foo" +21:1-4 TVariable "ggg" +21:7-10 TPatternSynonym "One" +23:6-9 TTypeConstructor "Doo" +23:12-15 TDataConstructor "Doo" +23:16-24 TModule "Prelude." +23:24-27 TTypeConstructor "Int" +24:6-10 TTypeSynonym "Bar1" +24:13-16 TTypeConstructor "Int" +25:6-10 TTypeSynonym "Bar2" +25:13-16 TTypeConstructor "Doo" +27:1-3 TFunction "bb" +27:8-11 TClass "Boo" +27:12-13 TTypeVariable "a" +27:18-19 TTypeVariable "a" +27:23-24 TTypeVariable "a" +28:1-3 TFunction "bb" +28:4-5 TVariable "x" +28:9-12 TClassMethod "boo" +28:13-14 TVariable "x" +29:1-3 TFunction "aa" +29:7-11 TTypeVariable "cool" +29:15-18 TTypeConstructor "Int" +29:22-26 TTypeVariable "cool" +30:1-3 TFunction "aa" +30:4-5 TVariable "x" +30:9-10 TVariable "c" +30:14-16 TFunction "aa" +30:17-18 TVariable "x" +30:19-20 TVariable "c" +31:12-14 TVariable "xx" +31:16-18 TVariable "yy" +32:11-13 TVariable "dd" +34:2-4 TVariable "zz" +34:6-8 TVariable "kk" +35:1-3 TFunction "cc" +35:7-10 TTypeConstructor "Foo" +35:15-18 TTypeConstructor "Int" +35:20-23 TTypeConstructor "Int" +35:28-31 TTypeConstructor "Int" +36:1-3 TFunction "cc" +36:4-5 TVariable "f" +36:7-9 TVariable "gg" +36:11-13 TVariable "vv" +37:10-12 TVariable "gg" +38:14-17 TRecordField "foo" +38:18-19 TOperator "$" +38:20-21 TVariable "f" +38:24-27 TRecordField "foo" +39:14-17 TRecordField "foo" +39:18-19 TOperator "$" +39:20-21 TVariable "f" +39:24-27 TRecordField "foo" +41:1-3 TFunction "go" +41:6-9 TRecordField "foo" +42:1-4 TFunction "add" +42:8-16 TModule "Prelude." +42:16-17 TOperator "+" +47:1-5 TVariable "main" +47:9-11 TTypeConstructor "IO" +48:1-5 TVariable "main" +48:8-16 TFunction "putStrLn" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs @@ -0,0 +1,48 @@ +-- patter syn +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +-- import Data.Set (Set, insert) + + +data Foo = Foo { foo :: Int } + +class Boo a where + boo :: a -> a + +instance Boo Int where + boo x = x + 1 + +data Dd = Dd Int + +pattern One = Foo 1 + +ggg = One + +data Doo = Doo Prelude.Int +type Bar1 = Int +type Bar2 = Doo + +bb :: (Boo a) => a -> a +bb x = boo x +aa :: cool -> Int -> cool +aa x = \c -> aa x c + where (xx, yy) = (1, 2) + dd = 1 + +(zz, kk) = (1, 2) +cc :: Foo -> (Int, Int) -> Int +cc f (gg, vv)= + case gg of + 1 -> foo $ f { foo = 1 } + 2 -> foo $ f { foo = 1 } + +go = foo +add = (Prelude.+) + +-- sub :: Int -> Int -> Int +-- sub x y = add x y + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected @@ -0,0 +1,5 @@ +4:7-10 TClass "Foo" +4:11-12 TTypeVariable "a" +5:3-6 TClassMethod "foo" +5:10-11 TTypeVariable "a" +5:15-18 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected @@ -0,0 +1,3 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StandaloneDeriving #-} +module TClassImportedDeriving where +-- deriving method source span of Show occurrence +data Foo = Foo deriving (Show) + +-- standalone deriving method not in the same position +-- deriving instance Eq Foo + +-- a :: Foo -> Foo -> Bool +-- a = (==) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected @@ -0,0 +1,12 @@ +5:13-18 TTypeFamily "XList" +5:19-20 TTypeVariable "a" +8:15-20 TTypeFamily "XList" +8:21-25 TTypeConstructor "Char" +8:28-33 TDataConstructor "XCons" +8:35-39 TTypeConstructor "Char" +8:42-47 TTypeFamily "XList" +8:48-52 TTypeConstructor "Char" +8:56-60 TDataConstructor "XNil" +11:15-20 TTypeFamily "XList" +11:26-35 TDataConstructor "XListUnit" +11:37-40 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +module TDatafamily where + +-- Declare a list-like data family +data family XList a + +-- Declare a list-like instance for Char +data instance XList Char = XCons !Char !(XList Char) | XNil + +-- Declare a number-like instance for () +data instance XList () = XListUnit !Int diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected @@ -0,0 +1,4 @@ +3:6-9 TTypeConstructor "Foo" +3:12-15 TDataConstructor "Foo" +3:16-19 TTypeConstructor "Int" +3:30-32 TClass "Eq" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected @@ -0,0 +1,5 @@ +3:8-17 TModule "System.IO" +5:1-3 TVariable "go" +5:7-9 TTypeConstructor "IO" +6:1-3 TVariable "go" +6:6-11 TFunction "print" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected @@ -0,0 +1,5 @@ +4:5-10 TVariable "hello" +5:1-6 TVariable "hello" +5:10-13 TTypeConstructor "Int" +6:1-6 TVariable "hello" +6:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs @@ -0,0 +1,9 @@ +module TDoc where + +-- | +-- `hello` +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected @@ -0,0 +1,11 @@ +3:1-2 TFunction "f" +3:13-14 TTypeVariable "a" +3:16-17 TTypeVariable "a" +3:21-22 TTypeVariable "a" +4:1-2 TFunction "f" +4:3-4 TVariable "x" +4:7-8 TVariable "x" +6:1-2 TVariable "x" +6:6-7 TTypeVariable "a" +7:1-2 TVariable "x" +7:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected @@ -0,0 +1,5 @@ +3:1-2 TVariable "y" +3:6-9 TTypeConstructor "Int" +4:1-2 TVariable "y" +4:9-10 TFunction "f" +4:11-12 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected @@ -0,0 +1,7 @@ +3:1-2 TFunction "f" +3:6-9 TTypeConstructor "Int" +3:13-16 TTypeConstructor "Int" +4:1-2 TFunction "f" +4:7-8 TFunction "g" +6:5-6 TFunction "g" +6:7-8 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected @@ -0,0 +1,17 @@ +3:6-8 TTypeSynonym "T1" +3:11-14 TTypeConstructor "Int" +3:18-21 TTypeConstructor "Int" +4:6-8 TTypeSynonym "T2" +4:18-19 TTypeVariable "a" +4:21-22 TTypeVariable "a" +4:26-27 TTypeVariable "a" +5:1-3 TFunction "f1" +5:7-9 TTypeSynonym "T1" +6:1-3 TFunction "f1" +6:4-5 TVariable "x" +6:8-9 TVariable "x" +7:1-3 TFunction "f2" +7:7-9 TTypeSynonym "T2" +8:1-3 TFunction "f2" +8:4-5 TVariable "x" +8:8-9 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs @@ -0,0 +1,9 @@ +module TFunctionUnderTypeSynonym where + +type T1 = Int -> Int +type T2 = forall a. a -> a +f1 :: T1 +f1 x = x +f2 :: T2 +f2 x = x + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected @@ -0,0 +1,13 @@ +5:6-9 TTypeConstructor "Lam" +6:3-7 TDataConstructor "Lift" +6:11-12 TTypeVariable "a" +6:36-39 TTypeConstructor "Lam" +6:40-41 TTypeVariable "a" +7:3-6 TDataConstructor "Lam" +7:12-15 TTypeConstructor "Lam" +7:16-17 TTypeVariable "a" +7:21-24 TTypeConstructor "Lam" +7:25-26 TTypeVariable "b" +7:36-39 TTypeConstructor "Lam" +7:41-42 TTypeVariable "a" +7:46-47 TTypeVariable "b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module TGADT where + +data Lam :: * -> * where + Lift :: a -> Lam a -- ^ lifted value + Lam :: (Lam a -> Lam b) -> Lam (a -> b) -- ^ lambda abstraction diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected @@ -0,0 +1,7 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:16-19 TTypeConstructor "Int" +5:10-14 TClass "Show" +5:15-18 TTypeConstructor "Foo" +6:5-9 TClassMethod "show" +6:12-21 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Show Foo where + show = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected @@ -0,0 +1,2 @@ +4:1-3 TFunction "go" +4:8-12 TClassMethod "show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = show + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs @@ -0,0 +1,5 @@ +module TModuleA where + +data Game = Game {a𐐀b :: Int} + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs @@ -0,0 +1,8 @@ +module TModuleB where + +import TModuleA +import qualified TModuleA + +go = Game 1 + +a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected @@ -0,0 +1,6 @@ +3:1-2 TVariable "x" +3:7-9 TClass "Eq" +3:10-11 TTypeVariable "a" +3:16-17 TTypeVariable "a" +4:1-2 TVariable "x" +4:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected @@ -0,0 +1,33 @@ +4:1-3 TFunction "go" +4:4-5 TFunction "f" +4:6-7 TVariable "x" +4:10-11 TFunction "f" +4:11-12 TOperator "$" +4:12-13 TVariable "x" +6:2-6 TOperator "$$$$" +7:1-2 TVariable "x" +7:7-11 TOperator "$$$$" +8:6-7 TTypeVariable "a" +8:8-11 TOperator ":+:" +8:12-13 TTypeVariable "b" +8:16-19 TDataConstructor "Add" +8:20-21 TTypeVariable "a" +8:22-23 TTypeVariable "b" +9:7-10 TOperator ":-:" +9:12-13 TTypeVariable "a" +9:14-15 TTypeVariable "b" +9:19-20 TTypeVariable "a" +9:22-23 TTypeVariable "b" +11:1-4 TFunction "add" +11:8-11 TTypeConstructor "Int" +11:12-15 TOperator ":+:" +11:16-19 TTypeConstructor "Int" +11:23-26 TTypeConstructor "Int" +11:27-30 TOperator ":-:" +11:31-34 TTypeConstructor "Int" +13:1-4 TFunction "add" +13:6-9 TDataConstructor "Add" +13:10-11 TVariable "x" +13:12-13 TVariable "y" +13:18-19 TVariable "x" +13:21-22 TVariable "y" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs @@ -0,0 +1,13 @@ +module TOperator where + +-- imported operator +go f x = f$x +-- operator defined in local module +($$$$) = b +x = 1 $$$$ 2 +data a :+: b = Add a b +type (:-:) a b = (a, b) +-- type take precedence over operator +add :: Int :+: Int -> Int :-: Int +-- class method take precedence over operator +add (Add x y) = (x, y) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected @@ -0,0 +1,2 @@ +4:1-2 TFunction "g" +4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected @@ -0,0 +1,1 @@ +5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected @@ -0,0 +1,7 @@ +3:2-3 TVariable "a" +3:5-6 TVariable "b" +5:1-2 TFunction "f" +5:3-4 TFunction "g" +5:5-6 TVariable "y" +5:9-10 TFunction "g" +5:11-12 TVariable "y" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected @@ -0,0 +1,12 @@ +3:18-27 TModule "Data.List" +6:1-2 TVariable "a" +6:5-13 TModule "Prelude." +6:13-22 TVariable "undefined" +7:1-2 TVariable "b" +7:8-18 TModule "Data.List." +7:18-22 TClassMethod "elem" +8:1-2 TVariable "c" +8:6-14 TModule "Prelude." +8:14-15 TOperator "+" +9:1-2 TVariable "d" +9:6-7 TOperator "+" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs @@ -0,0 +1,9 @@ +module TQualifiedName where + +import qualified Data.List + + +a = Prelude.undefined +b = 1 `Data.List.elem` [1, 2] +c = (Prelude.+) 1 1 +d = (+) 1 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected @@ -0,0 +1,4 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:18-21 TRecordField "foo" +4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected @@ -0,0 +1,4 @@ +5:6-9 TTypeConstructor "Foo" +5:12-15 TDataConstructor "Foo" +5:18-21 TRecordField "boo" +5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected @@ -0,0 +1,8 @@ +4:13-16 TTypeFamily "Foo" +4:17-18 TTypeVariable "a" +5:3-6 TTypeFamily "Foo" +5:7-10 TTypeConstructor "Int" +5:13-16 TTypeConstructor "Int" +6:3-6 TTypeFamily "Foo" +6:7-8 TTypeVariable "a" +6:11-17 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected @@ -0,0 +1,1 @@ +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected @@ -0,0 +1,4 @@ +4:1-6 TVariable "hello" +4:10-13 TTypeConstructor "Int" +5:1-6 TVariable "hello" +5:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -0,0 +1,548 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Ide.Plugin.Splice + ( descriptor, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow ( Arrow(first) ) +import Control.Exception ( SomeException ) +import qualified Control.Foldl as L +import Control.Lens (Identity (..), ix, view, (%~), + (<&>), (^.)) +import Control.Monad ( guard, unless, forM ) +import Control.Monad.Error.Class ( MonadError(throwError) ) +import Control.Monad.Extra (eitherM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) +import Control.Monad.Trans.Maybe +import Data.Aeson hiding (Null) +import qualified Data.Bifunctor as B (first) +import Data.Foldable (Foldable (foldl')) +import Data.Function +import Data.Generics +import qualified Data.Kind as Kinds +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe, + mapMaybe) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PluginUtils +import Development.IDE.GHC.Compat as Compat hiding (getLoc) +import Development.IDE.GHC.Compat.ExactPrint +import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT)) + +#if MIN_VERSION_ghc(9,4,1) + +import GHC.Data.Bag (Bag) + +#endif + +import GHC.Exts + + +import GHC.Parser.Annotation (SrcSpanAnn'(..)) +import qualified GHC.Types.Error as Error + + +import Ide.Plugin.Splice.Types +import Ide.Types +import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) +import Language.LSP.Server +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as J +import Ide.Plugin.Error (PluginError(PluginInternalError)) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId "Provides a code action to evaluate a TemplateHaskell splice") + { pluginCommands = commands + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeAction + } + +commands :: [PluginCommand IdeState] +commands = + [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace + -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented + ] + +newtype SubSpan = SubSpan {runSubSpan :: SrcSpan} + +instance Eq SubSpan where + (==) = (==) `on` runSubSpan + +instance Ord SubSpan where + (<=) = coerce isSubspanOf + +expandTHSplice :: + -- | Inplace? + ExpandStyle -> + CommandFunction IdeState ExpandSpliceParams +expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do + clientCapabilities <- getClientCapabilities + rio <- askRunInIO + let reportEditor :: ReportEditor + reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit + expandManually fp = do + mresl <- + liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp + (TcModuleResult {..}, _) <- + maybe + (throwError $ PluginInternalError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." + ) + pure mresl + reportEditor + MessageType_Warning + [ "Expansion in type-checking phase failed;" + , "trying to expand manually, but note that it is less rigorous." + ] + pm <- runActionE "expandTHSplice.fallback.GetParsedModule" ideState $ + useE GetParsedModule fp + (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm + + manualCalcEdit + clientCapabilities + reportEditor + range + ps + hscEnv + tmrTypechecked + spliceSpan + _eStyle + params + + withTypeChecked fp TcModuleResult {..} = do + (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + let Splices {..} = tmrTopLevelSplices + let exprSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan exprSplices + _patSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan patSplices + typeSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan typeSplices + declSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan declSplices + + graftSpliceWith :: + forall ast. + HasSplice AnnListItem ast => + Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs)) -> + Maybe (Either String WorkspaceEdit) + graftSpliceWith expandeds = + expandeds <&> \(_, expanded) -> + transform + dflags + clientCapabilities + verTxtDocId + (graft (RealSrcSpan spliceSpan Nothing) expanded) + ps + maybe (throwError $ PluginInternalError "No splice information found") (either (throwError . PluginInternalError . T.pack) pure) $ + case spliceContext of + Expr -> graftSpliceWith exprSuperSpans + Pat -> + + graftSpliceWith _patSuperSpans + + HsType -> graftSpliceWith typeSuperSpans + HsDecl -> + declSuperSpans <&> \(_, expanded) -> + transform + dflags + clientCapabilities + verTxtDocId + (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) + ps + <&> + -- FIXME: Why ghc-exactprint sweeps preceding comments? + adjustToRange (verTxtDocId ^. J.uri) range + + res <- liftIO $ runMaybeT $ do + + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri (verTxtDocId ^. J.uri) + eedits <- + ( lift . runExceptT . withTypeChecked fp + =<< MaybeT + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + ) + <|> lift (runExceptT $ expandManually fp) + + case eedits of + Left err -> do + reportEditor + MessageType_Error + [T.pack $ "Error during expanding splice: " <> show (pretty err)] + pure (Left err) + Right edits -> + pure (Right edits) + case res of + Nothing -> pure $ Right $ InR Null + Just (Left err) -> pure $ Left $ err + Just (Right edit) -> do + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ Right $ InR Null + + where + range = realSrcSpanToRange spliceSpan + srcSpan = RealSrcSpan spliceSpan Nothing + + +setupHscEnv + :: IdeState + -> NormalizedFilePath + -> ParsedModule + -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags) +setupHscEnv ideState fp pm = do + hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ + useE GhcSessionDeps fp + let ps = annotateParsedSource pm + hscEnv0 = hscEnvWithImportPaths hscEnvEq + modSum = pm_mod_summary pm + hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + pure (ps, hscEnv, hsc_dflags hscEnv) + +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv +setupDynFlagsForGHCiLike env dflags = do + let dflags3 = setInterpreterLinkerOptions dflags + platform = targetPlatform dflags3 + dflags3a = setWays hostFullWays dflags3 + dflags3b = + foldl gopt_set dflags3a $ + concatMap (wayGeneralFlags platform) hostFullWays + dflags3c = + foldl gopt_unset dflags3b $ + concatMap (wayUnsetGeneralFlags platform) hostFullWays + dflags4 = + dflags3c + `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + `gopt_unset` Opt_DiagnosticsShowCaret + initializePlugins (hscSetFlags dflags4 env) + +adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit +adjustToRange uri ran (WorkspaceEdit mhult mlt x) = + WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) x + where + adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit + adjustTextEdits eds = + let minStart = + case L.fold (L.premap (view J.range) L.minimum) eds of + Nothing -> error "impossible" + Just v -> v + in adjustLine minStart <$> eds + + adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) + adjustATextEdits = fmap $ \case + InL t -> InL $ runIdentity $ adjustTextEdits (Identity t) + InR AnnotatedTextEdit{_range, _newText, _annotationId} -> + let oldTE = TextEdit{_range,_newText} + in let TextEdit{_range,_newText} = runIdentity $ adjustTextEdits (Identity oldTE) + in InR $ AnnotatedTextEdit{_range,_newText,_annotationId} + + adjustWS = ix uri %~ adjustTextEdits + adjustDoc :: DocumentChange -> DocumentChange + adjustDoc (InR es) = InR es + adjustDoc (InL es) + | es ^. J.textDocument . J.uri == uri = + InL $ es & J.edits %~ adjustATextEdits + | otherwise = InL es + + adjustLine :: Range -> TextEdit -> TextEdit + adjustLine bad = + J.range %~ \r -> + if r == bad then ran else bad + +-- Define a pattern to get hold of a `SrcSpan` from the location part of a +-- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations; +-- earlier it will just be a plain `SrcSpan`. +{-# COMPLETE AsSrcSpan #-} +pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a +pattern AsSrcSpan locA <- SrcSpanAnn {locA} + +findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] +findSubSpansDesc srcSpan = + sortOn (Down . SubSpan . fst) + . mapMaybe + ( \(L (AsSrcSpan spn) _, e) -> do + guard (spn `isSubspanOf` srcSpan) + pure (spn, e) + ) + +data SpliceClass where + OneToOneAST :: HasSplice AnnListItem ast => Proxy# ast -> SpliceClass + IsHsDecl :: SpliceClass + +#if MIN_VERSION_ghc(9,5,0) +data HsSpliceCompat pass + = UntypedSplice (HsUntypedSplice pass) + | TypedSplice (LHsExpr pass) +#endif + + +class (Outputable (ast GhcRn), ASTElement l (ast GhcPs)) => HasSplice l ast where + type SpliceOf ast :: Kinds.Type -> Kinds.Type + matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) + expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) + +instance HasSplice AnnListItem HsExpr where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf HsExpr = HsSpliceCompat + matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl) + matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) +#else + type SpliceOf HsExpr = HsSplice + matchSplice _ (HsSpliceE _ spl) = Just spl +#endif + matchSplice _ _ = Nothing +#if MIN_VERSION_ghc(9,5,0) + expandSplice _ (UntypedSplice e) = fmap (first Right) $ rnUntypedSpliceExpr e + expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice e +#else + expandSplice _ = fmap (first Right) . rnSpliceExpr +#endif + +instance HasSplice AnnListItem Pat where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf Pat = HsUntypedSplice +#else + type SpliceOf Pat = HsSplice +#endif + matchSplice _ (SplicePat _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = +#if MIN_VERSION_ghc(9,5,0) + fmap (first (Left . unLoc . utsplice_result . snd )) . +#endif + rnSplicePat + + +instance HasSplice AnnListItem HsType where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf HsType = HsUntypedSplice +#else + type SpliceOf HsType = HsSplice +#endif + matchSplice _ (HsSpliceTy _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = fmap (first Right) . rnSpliceType + +classifyAST :: SpliceContext -> SpliceClass +classifyAST = \case + Expr -> OneToOneAST @HsExpr proxy# + HsDecl -> IsHsDecl + Pat -> OneToOneAST @Pat proxy# + HsType -> OneToOneAST @HsType proxy# + +type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m () + +manualCalcEdit :: + ClientCapabilities -> + ReportEditor -> + Range -> + Annotated ParsedSource -> + HscEnv -> + TcGblEnv -> + RealSrcSpan -> + ExpandStyle -> + ExpandSpliceParams -> + ExceptT PluginError IO WorkspaceEdit +manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do + (warns, resl) <- + ExceptT $ do + (msgs, eresl) <- + initTcWithGbl hscEnv typechkd srcSpan $ + case classifyAST spliceContext of + IsHsDecl -> fmap (fmap $ adjustToRange (verTxtDocId ^. J.uri) ran) $ + flip (transformM dflags clientCapabilities verTxtDocId) ps $ + graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case + (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do + eExpr <- + eitherM (fail . show) pure + $ TransformT $ lift + ( lift $ + Util.try @_ @SomeException $ + (fst <$> rnTopSpliceDecls spl) + ) + pure $ Just eExpr + _ -> pure Nothing + OneToOneAST astP -> + flip (transformM dflags clientCapabilities verTxtDocId) ps $ + graftWithM (RealSrcSpan srcSpan Nothing) $ \case + (L _spn (matchSplice astP -> Just spl)) -> do + eExpr <- + eitherM (fail . show) pure + $ TransformT $ lift + ( lift $ + Util.try @_ @SomeException $ + (fst <$> expandSplice astP spl) + ) + Just <$> case eExpr of + Left x -> pure $ L _spn x + Right y -> unRenamedE dflags y + _ -> pure Nothing + let (warns, errs) = + (Error.getWarningMessages msgs, Error.getErrorMessages msgs) + pure $ (warns,) <$> maybe (throwError $ PluginInternalError $ T.pack $ showErrors errs) + (B.first (PluginInternalError . T.pack)) eresl + + unless + (null warns) + $ reportEditor + MessageType_Warning + [ "Warning during expanding: " + , "" + , T.pack (showErrors warns) + ] + pure resl + where + dflags = hsc_dflags hscEnv + +#if MIN_VERSION_ghc(9,4,1) + showErrors = showBag +#else + showErrors = show +#endif + +#if MIN_VERSION_ghc(9,4,1) +showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String +showBag = show . fmap (fmap toDiagnosticMessage) + +toDiagnosticMessage :: forall a. Error.Diagnostic a => a -> Error.DiagnosticMessage +toDiagnosticMessage message = + Error.DiagnosticMessage + { diagMessage = Error.diagnosticMessage +#if MIN_VERSION_ghc(9,5,0) + (Error.defaultDiagnosticOpts @a) +#endif + message + + , diagReason = Error.diagnosticReason message + , diagHints = Error.diagnosticHints message + } +#endif + +-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? +unRenamedE :: + forall ast m l. + (Fail.MonadFail m, HasSplice l ast) => + DynFlags -> + ast GhcRn -> + TransformT m (LocatedAn l (ast GhcPs)) +unRenamedE dflags expr = do + uniq <- show <$> uniqueSrcSpanT + expr' <- + either (fail . showErrors) pure $ + parseAST @_ @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr + pure expr' + where +#if MIN_VERSION_ghc(9,4,1) + showErrors = showBag . Error.getMessages +#else + showErrors = show +#endif + +data SearchResult r = + Continue | Stop | Here r + deriving (Read, Show, Eq, Ord, Data, Typeable) + +fromSearchResult :: SearchResult a -> Maybe a +fromSearchResult (Here r) = Just r +fromSearchResult _ = Nothing + +-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) +-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? +codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeAction state plId (CodeActionParams _ _ docId ran _) = do + verTxtDocId <- lift $ getVersionedTextDoc docId + liftIO $ fmap (fromMaybe ( InL [])) $ + runMaybeT $ do + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + ParsedModule {..} <- + MaybeT . runAction "splice.codeAction.GitHieAst" state $ + use GetParsedModule fp + let spn = rangeToRealSrcSpan fp ran + mouterSplice = something' (detectSplice spn) pm_parsed_source + mcmds <- forM mouterSplice $ + \(spliceSpan, spliceContext) -> + forM expandStyles $ \(_, (title, cmdId)) -> do + let params = ExpandSpliceParams {verTxtDocId, ..} + act = mkLspCommand plId cmdId title (Just [toJSON params]) + pure $ + InR $ + CodeAction title (Just CodeActionKind_RefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing + + pure $ InL $ fromMaybe mempty mcmds + where + theUri = docId ^. J.uri + detectSplice :: + RealSrcSpan -> + GenericQ (SearchResult (RealSrcSpan, SpliceContext)) + detectSplice spn = + let + spanIsRelevant x = RealSrcSpan spn Nothing `isSubspanOf` x + in + mkQ + Continue + ( \case + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs) + | spanIsRelevant l -> + case expr of +#if MIN_VERSION_ghc(9,5,0) + HsTypedSplice{} -> Here (spLoc, Expr) + HsUntypedSplice{} -> Here (spLoc, Expr) +#else + HsSpliceE {} -> Here (spLoc, Expr) +#endif + _ -> Continue + _ -> Stop + ) + `extQ` \case + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) pat :: LPat GhcPs) + | spanIsRelevant l -> + case pat of + SplicePat{} -> Here (spLoc, Pat) + _ -> Continue + _ -> Stop + `extQ` \case + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) ty :: LHsType GhcPs) + | spanIsRelevant l -> + case ty of + HsSpliceTy {} -> Here (spLoc, HsType) + _ -> Continue + _ -> Stop + `extQ` \case + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) decl :: LHsDecl GhcPs) + | spanIsRelevant l -> + case decl of + SpliceD {} -> Here (spLoc, HsDecl) + _ -> Continue + _ -> Stop + +-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received, +-- and picks innermost result. +something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a) +something' f = go + where + go :: GenericQ (Maybe a) + go x = + case f x of + Stop -> Nothing + resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Splice.Types where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as T + -- This import is needed for the ToJSON/FromJSON instances of RealSrcSpan +import Development.IDE () +import Development.IDE.GHC.Compat (RealSrcSpan) +import GHC.Generics (Generic) +import Ide.Types (CommandId) +import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) + +-- | Parameter for the addMethods PluginCommand. +data ExpandSpliceParams = ExpandSpliceParams + { verTxtDocId :: VersionedTextDocumentIdentifier + , spliceSpan :: RealSrcSpan + , spliceContext :: SpliceContext + } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- FIXME: HsDecl needs different treatment of splicing. +data SpliceContext = Expr | HsDecl | Pat | HsType + deriving (Read, Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data ExpandStyle = Inplace | Commented + deriving (Read, Show, Eq, Ord, Generic) + +expandStyles :: [(ExpandStyle, (T.Text, CommandId))] +expandStyles = + [ (Inplace, (inplaceCmdName, expandInplaceId)) + -- , (Commented, commentedCmdName, expandCommentedId) + ] + +toExpandCmdTitle :: ExpandStyle -> T.Text +toExpandCmdTitle Inplace = inplaceCmdName +toExpandCmdTitle Commented = commentedCmdName + +toCommandId :: ExpandStyle -> CommandId +toCommandId Inplace = expandInplaceId +toCommandId Commented = expandCommentedId + +expandInplaceId, expandCommentedId :: CommandId +expandInplaceId = "expandTHSpliceInplace" +expandCommentedId = "expandTHSpliceCommented" + +inplaceCmdName :: T.Text +inplaceCmdName = "expand TemplateHaskell Splice (in-place)" + +commentedCmdName :: T.Text +commentedCmdName = "expand TemplateHaskell Splice (commented-out)" diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Main + ( main + ) where + +import Control.Monad (void) +import Data.List (find) +import Data.Row +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Ide.Plugin.Splice as Splice +import Ide.Plugin.Splice.Types +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +splicePlugin :: PluginTestDescriptor () +splicePlugin = mkPluginTestDescriptor' Splice.descriptor "splice" + +tests :: TestTree +tests = testGroup "splice" + [ goldenTest "TSimpleExp" Inplace 6 15 + , goldenTest "TSimpleExp" Inplace 6 24 + , goldenTest "TTypeAppExp" Inplace 7 5 + , goldenTest "TErrorExp" Inplace 6 15 + , goldenTest "TErrorExp" Inplace 6 51 + , goldenTest "TQQExp" Inplace 6 17 + , goldenTest "TQQExp" Inplace 6 25 + , goldenTest "TQQExpError" Inplace 6 13 + , goldenTest "TQQExpError" Inplace 6 22 + , testGroup "Pattern Splices" + [ goldenTest "TSimplePat" Inplace 6 3 + , goldenTest "TSimplePat" Inplace 6 22 + , goldenTest "TSimplePat" Inplace 6 3 + , goldenTest "TSimplePat" Inplace 6 22 + , goldenTest "TErrorPat" Inplace 6 3 + , goldenTest "TErrorPat" Inplace 6 18 + , goldenTest "TQQPat" Inplace 6 3 + , goldenTest "TQQPat" Inplace 6 11 + , goldenTest "TQQPatError" Inplace 6 3 + , goldenTest "TQQPatError" Inplace 6 11 + ] + , goldenTest "TSimpleType" Inplace 5 12 + , goldenTest "TSimpleType" Inplace 5 22 + , goldenTest "TTypeTypeError" Inplace 7 12 + , goldenTest "TTypeTypeError" Inplace 7 52 + , goldenTest "TQQType" Inplace 8 19 + , goldenTest "TQQType" Inplace 8 28 + , goldenTest "TQQTypeTypeError" Inplace 8 19 + , goldenTest "TQQTypeTypeError" Inplace 8 28 + , goldenTest "TSimpleDecl" Inplace 8 1 + , goldenTest "TQQDecl" Inplace 5 1 + , goldenTestWithEdit "TTypeKindError" ( + if ghcVersion >= GHC96 then + "96-expected" + else + "expected" + ) Inplace 7 9 + , goldenTestWithEdit "TDeclKindError" "expected" Inplace 8 1 + ] + +goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree +goldenTest fp tc line col = + goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do + -- wait for the entire build to finish, so that code actions that + -- use stale data will get uptodate stuff + void waitForBuildQueue + actions <- getCodeActions doc $ pointRange line col + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of + Just (InR CodeAction {_command = Just c}) -> do + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + _ -> liftIO $ assertFailure "No CodeAction detected" + +goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree +goldenTestWithEdit fp expect tc line col = + goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp expect "hs" $ \doc -> do + orig <- documentContents doc + let + lns = T.lines orig + theRange = + Range + { _start = Position 0 0 + , _end = Position (fromIntegral $ length lns + 1) 1 + } + waitForAllProgressDone -- cradle + waitForAllProgressDone + alt <- liftIO $ T.readFile (fp <.> "error.hs") + void $ applyEdit doc $ TextEdit theRange alt + changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange + .+ #rangeLength .== Nothing + .+ #text .== alt] + void waitForDiagnostics + -- wait for the entire build to finish + void waitForBuildQueue + actions <- getCodeActions doc $ pointRange line col + case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of + Just (InR CodeAction {_command = Just c}) -> do + executeCommand c + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + _ -> liftIO $ assertFailure "No CodeAction detected" + +testDataDir :: FilePath +testDataDir = "plugins" "hls-splice-plugin" "test" "testdata" + +pointRange :: Int -> Int -> Range +pointRange (subtract 1 -> fromIntegral -> line) (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) + +-- | Get the title of a code action. +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL {} = Nothing +codeActionTitle (InR CodeAction {_title}) = Just _title diff --git a/plugins/hls-splice-plugin/test/testdata/QQ.hs b/plugins/hls-splice-plugin/test/testdata/QQ.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/QQ.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +module QQ (str) where + +import Language.Haskell.TH + ( mkName, + stringL, + litP, + clause, + litE, + normalB, + funD, + sigD, + litT, + strTyLit ) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) + +str :: QuasiQuoter +str = + QuasiQuoter + { quoteExp = litE . stringL + , quotePat = litP . stringL + , quoteType = litT . strTyLit + , quoteDec = \name -> + sequence + [ sigD (mkName name) [t|String|] + , funD (mkName name) [clause [] (normalB $ litE $ stringL name) []] + ] + } diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclKindError.error.hs b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.error.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.error.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ,sigD (mkName "bar") [t|Int|] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclKindError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.expected.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +foo :: Int +foo = 42 +bar :: Int +-- Bar +-- ee +-- dddd diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclKindError.hs b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TDeclKindError.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/plugins/hls-splice-plugin/test/testdata/TErrorExp.expected.hs b/plugins/hls-splice-plugin/test/testdata/TErrorExp.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TErrorExp.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return (42, ()) diff --git a/plugins/hls-splice-plugin/test/testdata/TErrorExp.hs b/plugins/hls-splice-plugin/test/testdata/TErrorExp.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TErrorExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return $(tupE [litE $ integerL 42, tupE []]) diff --git a/plugins/hls-splice-plugin/test/testdata/TErrorPat.expected.hs b/plugins/hls-splice-plugin/test/testdata/TErrorPat.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TErrorPat.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorPat where +import Language.Haskell.TH ( conP ) + +f :: () -> () +f True = x diff --git a/plugins/hls-splice-plugin/test/testdata/TErrorPat.hs b/plugins/hls-splice-plugin/test/testdata/TErrorPat.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TErrorPat.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TErrorPat where +import Language.Haskell.TH ( conP ) + +f :: () -> () +f $(conP 'True []) = x diff --git a/plugins/hls-splice-plugin/test/testdata/TQQDecl.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQDecl.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQDecl.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQDecl where +import QQ (str) + +foo :: String +foo = "foo" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQDecl.hs b/plugins/hls-splice-plugin/test/testdata/TQQDecl.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQDecl.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQDecl where +import QQ (str) + +[str|foo|] diff --git a/plugins/hls-splice-plugin/test/testdata/TQQExp.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQExp.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQExp.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExp where +import QQ + +main :: IO () +main = putStrLn "str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQExp.hs b/plugins/hls-splice-plugin/test/testdata/TQQExp.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExp where +import QQ + +main :: IO () +main = putStrLn [str|str|] diff --git a/plugins/hls-splice-plugin/test/testdata/TQQExpError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQExpError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQExpError.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExpError where +import QQ + +main :: IO () +main = pure "str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQExpError.hs b/plugins/hls-splice-plugin/test/testdata/TQQExpError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQExpError.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQExpError where +import QQ + +main :: IO () +main = pure [str|str|] diff --git a/plugins/hls-splice-plugin/test/testdata/TQQPat.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQPat.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQPat.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPat where +import QQ + +f :: String -> IO () +f "str" = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQPat.hs b/plugins/hls-splice-plugin/test/testdata/TQQPat.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQPat.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPat where +import QQ + +f :: String -> IO () +f [str|str|] = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQPatError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQPatError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQPatError.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPatError where +import QQ + +f :: () -> IO () +f "str" = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQPatError.hs b/plugins/hls-splice-plugin/test/testdata/TQQPatError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQPatError.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +module TQQPatError where +import QQ + +f :: () -> IO () +f [str|str|] = putStrLn "is str" +f _ = putStrLn " not str" diff --git a/plugins/hls-splice-plugin/test/testdata/TQQType.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQType.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQType.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQType where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy "str") +main = return Proxy diff --git a/plugins/hls-splice-plugin/test/testdata/TQQType.hs b/plugins/hls-splice-plugin/test/testdata/TQQType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQType.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQType where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy [str|str|]) +main = return Proxy diff --git a/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy "str") +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.hs b/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TQQTypeTypeError.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +module TQQTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy(..) ) +import QQ + +main :: IO (Proxy [str|str|]) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.expected.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +foo :: Int +foo = 42 +-- Bar +-- ee +-- dddd diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleDecl.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module TSimpleDecl where +import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD ) + +-- Foo +-- Bar +$(sequence + [sigD (mkName "foo") [t|Int|] + ,funD (mkName "foo") [clause [] (normalB [|42|]) []] + ] + ) +-- Bar +-- ee +-- dddd diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleExp.expected.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleExp.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleExp.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleExp.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleExp.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleExp.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleExp where +import Language.Haskell.TH ( tupE, litE, integerL ) + +main :: IO () +main = return $(tupE []) diff --git a/plugins/hls-splice-plugin/test/testdata/TSimplePat.expected.hs b/plugins/hls-splice-plugin/test/testdata/TSimplePat.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimplePat.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimplePat where +import Language.Haskell.TH ( varP, mkName ) + +f :: x -> x +f x = x diff --git a/plugins/hls-splice-plugin/test/testdata/TSimplePat.hs b/plugins/hls-splice-plugin/test/testdata/TSimplePat.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimplePat.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimplePat where +import Language.Haskell.TH ( varP, mkName ) + +f :: x -> x +f $(varP $ mkName "x") = x diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleType.expected.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleType.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleType.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleType where +import Language.Haskell.TH ( tupleT ) + +main :: IO () +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TSimpleType.hs b/plugins/hls-splice-plugin/test/testdata/TSimpleType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TSimpleType.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TSimpleType where +import Language.Haskell.TH ( tupleT ) + +main :: IO $(tupleT 0) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.expected.hs b/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module TTypeAppExp where +import Data.Proxy + +f :: Proxy Int +f = Proxy @Int diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs b/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module TTypeAppExp where +import Data.Proxy + +f :: Proxy Int +f = $([|Proxy @Int|]) diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeKindError.96-expected.hs b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.96-expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.96-expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: 42 +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeKindError.error.hs b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.error.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.error.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: $(litT (numTyLit 42)) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeKindError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: (42) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeKindError.hs b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeKindError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: IO () +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.expected.hs b/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy ) + +main :: IO (Proxy 42) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.hs b/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TTypeTypeError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeTypeError where +import Language.Haskell.TH ( appT, numTyLit, litT, conT ) +import Data.Proxy ( Proxy ) + +main :: IO $(conT ''Proxy `appT` litT (numTyLit 42)) +main = return () diff --git a/plugins/hls-splice-plugin/test/testdata/hie.yaml b/plugins/hls-splice-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/hie.yaml @@ -0,0 +1,21 @@ +cradle: + direct: + arguments: + - QQ.hs + - TQQExpError.hs + - TSimpleExp.hs + - TTypeAppExp.hs + - TDeclKindError.hs + - TQQPat.hs + - TSimplePat.hs + - TErrorExp.hs + - TQQPatError.hs + - TSimpleType.hs + - TErrorPat.hs + - TQQType.hs + - TTypeKindError.hs + - TQQDecl.hs + - TQQTypeTypeError.hs + - TTypeTypeError.hs + - TQQExp.hs + - TSimpleDecl.hs diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +module Ide.Plugin.Stan (descriptor, Log) where + +import Compat.HieTypes (HieFile (..)) +import Control.DeepSeq (NFData) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.Rules (getHieFile) +import qualified Development.IDE.Core.Shake as Shake +import GHC.Generics (Generic) +import Ide.Plugin.Config (PluginConfig (..)) +import Ide.Types (PluginDescriptor (..), PluginId, + configHasDiagnostics, + configInitialGenericConfig, + defaultConfigDescriptor, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap, + getStanConfig) +import Stan.Analysis (Analysis (..), runAnalysis) +import Stan.Category (Category (..)) +import Stan.Cli (StanArgs (..)) +import Stan.Config (Config, ConfigP (..), applyConfig) +import Stan.Config.Pretty (prettyConfigCli) +import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), envVarsToText) +import Stan.Inspection (Inspection (..)) +import Stan.Inspection.All (inspectionsIds, inspectionsMap) +import Stan.Observation (Observation (..)) +import Stan.Report.Settings (OutputSettings (..), + ToggleSolution (..), + Verbosity (..)) +import Stan.Toml (usedTomlFiles) +import System.Directory (makeRelativeToCurrentDirectory) +import Trial (Fatality, Trial (..), fiasco, + pattern FiascoL, pattern ResultL, + prettyTrial, prettyTrialWith) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId desc) + { pluginRules = rules recorder plId + , pluginConfigDescriptor = defConfigDescriptor + { configHasDiagnostics = True + -- We disable this plugin by default because users have been complaining about + -- the diagnostics, see https://github.com/haskell/haskell-language-server/issues/3916 + , configInitialGenericConfig = (configInitialGenericConfig defConfigDescriptor) + { plcGlobalOn = False + } + } + } + where + defConfigDescriptor = defaultConfigDescriptor + desc = "Provides stan diagnostics. Built with stan-" <> VERSION_stan + +data Log = LogShake !Shake.Log + | LogWarnConf ![(Fatality, T.Text)] + | LogDebugStanConfigResult ![FilePath] !(Trial T.Text Config) + | LogDebugStanEnvVars !EnvVars + +-- We use this function to remove the terminal escape sequences emmited by Trial pretty printing functions. +-- See https://github.com/kowainik/trial/pull/73#issuecomment-1868233235 +stripModifiers :: T.Text -> T.Text +stripModifiers = go "" + where + go acc txt = + case T.findIndex (== '\x1B') txt of + Nothing -> acc <> txt + Just index -> let (beforeEsc, afterEsc) = T.splitAt index txt + in go (acc <> beforeEsc) (consumeEscapeSequence afterEsc) + consumeEscapeSequence :: T.Text -> T.Text + consumeEscapeSequence txt = + case T.findIndex (== 'm') txt of + Nothing -> txt + Just index -> T.drop (index + 1) txt + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogWarnConf errs -> "Fiasco encountered when trying to load stan configuration. Using default inspections:" + <> line <> (pretty $ show errs) + LogDebugStanConfigResult fps t -> "Config result using: " + <> pretty fps <> line <> pretty (stripModifiers $ prettyTrialWith (T.unpack . prettyConfigCli) t) + LogDebugStanEnvVars envVars -> "EnvVars " <> + case envVars of + EnvVars trial@(FiascoL _) -> pretty (stripModifiers $ prettyTrial trial) + + -- if the envVars are not set, 'envVarsToText returns an empty string' + _ -> "found: " <> (pretty $ envVarsToText envVars) + +data GetStanDiagnostics = GetStanDiagnostics + deriving (Eq, Show, Generic) + +instance Hashable GetStanDiagnostics + +instance NFData GetStanDiagnostics + +type instance RuleResult GetStanDiagnostics = () + +rules :: Recorder (WithPriority Log) -> PluginId -> Rules () +rules recorder plId = do + define (cmapWithPrio LogShake recorder) $ + \GetStanDiagnostics file -> do + config <- getPluginConfigAction plId + if plcGlobalOn config && plcDiagnosticsOn config then do + maybeHie <- getHieFile file + case maybeHie of + Nothing -> return ([], Nothing) + Just hie -> do + let isLoud = False -- in Stan: notJson = not isLoud + let stanArgs = + StanArgs + { stanArgsHiedir = "" -- :: !FilePath -- ^ Directory with HIE files + , stanArgsCabalFilePath = [] -- :: ![FilePath] -- ^ Path to @.cabal@ files. + , stanArgsOutputSettings = OutputSettings NonVerbose ShowSolution -- :: !OutputSettings -- ^ Settings for output terminal report + -- doesnt matter, because it is silenced by isLoud + , stanArgsReport = Nothing -- :: !(Maybe ReportArgs) -- ^ @HTML@ report settings + , stanArgsUseDefaultConfigFile = fiasco "" -- :: !(TaggedTrial Text Bool) -- ^ Use default @.stan.toml@ file + , stanArgsConfigFile = Nothing -- :: !(Maybe FilePath) -- ^ Path to a custom configurations file. + , stanArgsConfig = ConfigP + { configChecks = fiasco "'hls-stan-plugin' doesn't receive CLI options for: checks" + , configRemoved = fiasco "'hls-stan-plugin' doesn't receive CLI options for: remove" + , configIgnored = fiasco "'hls-stan-plugin' doesn't receive CLI options for: ignore" + } + -- if they are not fiascos, .stan.toml's aren't taken into account + ,stanArgsJsonOut = not isLoud -- :: !Bool -- ^ Output the machine-readable output in JSON format instead. + } + + (configTrial, useDefConfig, env) <- liftIO $ getStanConfig stanArgs isLoud + tomlsUsedByStan <- liftIO $ usedTomlFiles useDefConfig (stanArgsConfigFile stanArgs) + logWith recorder Debug (LogDebugStanConfigResult tomlsUsedByStan configTrial) + + -- If envVar is set to 'False', stan will ignore all local and global .stan.toml files + logWith recorder Debug (LogDebugStanEnvVars env) + + -- Note that Stan works in terms of relative paths, but the HIE come in as absolute. Without + -- making its path relative, the file name(s) won't line up with the associated Map keys. + relativeHsFilePath <- liftIO $ makeRelativeToCurrentDirectory $ fromNormalizedFilePath file + let hieRelative = hie{hie_hs_file=relativeHsFilePath} + + (checksMap, ignoredObservations) <- case configTrial of + FiascoL es -> do + logWith recorder Development.IDE.Warning (LogWarnConf es) + -- If we can't read the config file, default to using all inspections: + let allInspections = HM.fromList [(relativeHsFilePath, inspectionsIds)] + pure (allInspections, []) + ResultL _warnings stanConfig -> do + -- HashMap of *relative* file paths to info about enabled checks for those file paths. + let checksMap = applyConfig [relativeHsFilePath] stanConfig + pure (checksMap, configIgnored stanConfig) + + -- A Map from *relative* file paths (just one, in this case) to language extension info: + cabalExtensionsMap <- liftIO $ createCabalExtensionsMap isLoud (stanArgsCabalFilePath stanArgs) [hieRelative] + let analysis = runAnalysis cabalExtensionsMap checksMap ignoredObservations [hieRelative] + return (analysisToDiagnostics file analysis, Just ()) + else return ([], Nothing) + + action $ do + files <- getFilesOfInterestUntracked + void $ uses GetStanDiagnostics $ HM.keys files + where + analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic] + analysisToDiagnostics file = mapMaybe (observationToDianostic file) . toList . analysisObservations + observationToDianostic :: NormalizedFilePath -> Observation -> Maybe FileDiagnostic + observationToDianostic file Observation {observationSrcSpan, observationInspectionId} = + do + inspection <- HM.lookup observationInspectionId inspectionsMap + let + -- Looking similar to Stan CLI output + -- We do not use `prettyShowInspection` cuz Id is redundant here + -- `prettyShowSeverity` and `prettyShowCategory` would contain color + -- codes and are replaced, too + message :: T.Text + message = + T.unlines $ + [ " ✲ Name: " <> inspectionName inspection, + " ✲ Description: " <> inspectionDescription inspection, + " ✲ Severity: " <> (T.pack $ show $ inspectionSeverity inspection), + " ✲ Category: " <> T.intercalate " " + (map (("#" <>) . unCategory) $ toList $ inspectionCategory inspection), + "Possible solutions:" + ] + ++ map (" - " <>) (inspectionSolution inspection) + return ( file, + ShowDiag, + LSP.Diagnostic + { _range = realSrcSpanToRange observationSrcSpan, + _severity = Just LSP.DiagnosticSeverity_Hint, + _code = Just (LSP.InR $ unId (inspectionId inspection)), + _source = Just "stan", + _message = message, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + ) diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -0,0 +1,78 @@ +module Main + ( main, + ) +where + +import Control.Lens ((^.)) +import qualified Data.Text as T +import qualified Ide.Plugin.Stan as Stan +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +tests :: TestTree +tests = + testGroup + "stan suggestions" + [ testCase "provides diagnostics" $ + runStanSession "" $ do + doc <- openDoc "test.hs" "haskell" + diags@(reduceDiag : _) <- waitForDiagnosticsFromSource doc "stan" + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 0 0) (Position 3 19) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Hint + let expectedPrefix = " ✲ Name: " + assertBool "" $ T.isPrefixOf expectedPrefix (reduceDiag ^. L.message) + reduceDiag ^. L.source @?= Just "stan" + return () + , testCase "ignores diagnostics from .stan.toml" $ + runStanSession "" $ do + doc <- openDoc ("dir" "configTest.hs") "haskell" + diags <- waitForDiagnosticsFromSource doc "stan" + liftIO $ length diags @?= 0 + return () + , testCase "respects LANGUAGE pragmas in the source file" $ + runStanSession "" $ do + doc <- openDoc ("extensions-language-pragma" "LanguagePragmaTest.hs") "haskell" + diags <- waitForDiagnosticsFromSource doc "stan" + -- We must include at least one valid diagnostic in our test file to avoid + -- the false-positive case where Stan finds no analyses to perform due to a + -- bad mapping, which would also lead to zero diagnostics being returned. + liftIO $ length diags @?= 1 + return () + , testCase "respects language extensions defined in the .cabal file" $ + runStanSession "" $ do + doc <- openDoc ("extensions-cabal-file" "CabalFileTest.hs") "haskell" + diags <- waitForDiagnosticsFromSource doc "stan" + -- We need at least one valid diagnostic here too, for the same reason as above. + liftIO $ length diags @?= 1 + return () + ] + +testDir :: FilePath +testDir = "plugins" "hls-stan-plugin" "test" "testdata" + +stanPlugin :: PluginTestDescriptor Stan.Log +stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" + where + -- We have to explicitly enable the plugin as it is disabled by default as + -- per request: https://github.com/haskell/haskell-language-server/issues/3916 + -- + enabledStanDescriptor recorder plId = + let stanPluginDescriptor = Stan.descriptor recorder plId + in stanPluginDescriptor + { pluginConfigDescriptor = (pluginConfigDescriptor stanPluginDescriptor) + { configInitialGenericConfig = (configInitialGenericConfig (pluginConfigDescriptor stanPluginDescriptor)) + { plcGlobalOn = True + } + } + } + +runStanSession :: FilePath -> Session a -> IO a +runStanSession subdir = + failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) diff --git a/plugins/hls-stan-plugin/test/testdata/dir/configTest.hs b/plugins/hls-stan-plugin/test/testdata/dir/configTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/dir/configTest.hs @@ -0,0 +1,3 @@ +a = length [1..] + +b = undefined diff --git a/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/CabalFileTest.hs b/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/CabalFileTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/CabalFileTest.hs @@ -0,0 +1,7 @@ +module CabalFileTest () where + +-- With `StrictData` enabled in the `.cabal` file, Stan shouldn't complain here: +data A = A Int Int + +-- ...but it should still complain here! +kewlFunc = undefined diff --git a/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/cabal-file-test.cabal b/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/cabal-file-test.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/extensions-cabal-file/cabal-file-test.cabal @@ -0,0 +1,9 @@ +cabal-version: 3.0 +name: cabal-file-test +version: 0.0.0.0 + +library + exposed-modules: CabalFileTest + hs-source-dirs: extensions-cabal-file + -- Specifically, we're testing that Stan respects the following extension definition: + default-extensions: StrictData diff --git a/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/LanguagePragmaTest.hs b/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/LanguagePragmaTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/LanguagePragmaTest.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE StrictData #-} + +module LanguagePragmaTest () where + +-- With the above `StrictData` language pragma, Stan shouldn't complain here: +data A = A Int Int + +-- ...but it should still complain here! +kewlFunc = undefined diff --git a/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/language-pragma-test.cabal b/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/language-pragma-test.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/extensions-language-pragma/language-pragma-test.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: language-pragma-test +version: 0.0.0.0 + +-- Without at least a minimal valid `.cabal` file, Stan won't bother building its +-- map of language extensions. This means it also won't detect LANGUAGE pragmas +-- without this file. + +library + exposed-modules: LanguagePragmaTest + hs-source-dirs: extensions-language-pragma diff --git a/plugins/hls-stan-plugin/test/testdata/hie.yaml b/plugins/hls-stan-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - test.hs diff --git a/plugins/hls-stan-plugin/test/testdata/test.hs b/plugins/hls-stan-plugin/test/testdata/test.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stan-plugin/test/testdata/test.hs @@ -0,0 +1,4 @@ +orderPair x y + | x < y = 1 + | x > y = 2 + | otherwise = 3 diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.StylishHaskell + ( descriptor + , provider + ) +where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE hiding (getExtensions, + pluginHandlers) +import Development.IDE.Core.PluginUtils +import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), + extensionFlags) +import qualified Development.IDE.GHC.Compat.Util as Util +import GHC.LanguageExtensions.Type +import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.PluginUtils +import Ide.Types hiding (Config) +import Language.Haskell.Stylish +import Language.LSP.Protocol.Types as LSP +import System.Directory +import System.FilePath + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers provider + } + where + desc = "Provides formatting of Haskell files via stylish-haskell. Built with stylish-haskell-" <> VERSION_stylish_haskell + +-- | Formatter provider of stylish-haskell. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: FormattingHandler IdeState +provider ide _token typ contents fp _opts = do + (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp + let file = fromNormalizedFilePath fp + config <- liftIO $ loadConfigFrom file + mergedConfig <- liftIO $ getMergedConfig dyn config + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) + result = runStylishHaskell file mergedConfig selectedContents + case result of + Left err -> throwError $ PluginInternalError $ T.pack $ "stylishHaskellCmd: " ++ err + Right new -> pure $ LSP.InL [TextEdit range new] + where + getMergedConfig dyn config + | null (configLanguageExtensions config) + = do + logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags" + pure + $ config + { configLanguageExtensions = getExtensions dyn } + | otherwise + = pure config + + getExtensions = map showExtension . Util.toList . extensionFlags + + showExtension Cpp = "CPP" + showExtension other = show other + +-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml. +-- If no such file has been found, return default config. +loadConfigFrom :: FilePath -> IO Config +loadConfigFrom file = do + currDir <- getCurrentDirectory + setCurrentDirectory (takeDirectory file) + config <- loadConfig (makeVerbose False) Nothing + setCurrentDirectory currDir + pure config + +-- | Run stylish-haskell on the given text with the given configuration. +runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message + -> Config -- ^ Configuration for stylish-haskell + -> Text -- ^ Text to format + -> Either String Text -- ^ Either formatted Text or an error message +runStylishHaskell file config = fmap fromLines . fmt . toLines + where + fromLines = T.pack . unlines + fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config) + toLines = lines . T.unpack diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/test/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import qualified Ide.Plugin.StylishHaskell as StylishHaskell +import System.FilePath +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +stylishHaskellPlugin :: PluginTestDescriptor () +stylishHaskellPlugin = mkPluginTestDescriptor' StylishHaskell.descriptor "stylishHaskell" + +tests :: TestTree +tests = testGroup "stylish-haskell" + [ goldenWithStylishHaskell "formats a document" "StylishHaskell" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) + , goldenWithStylishHaskell "formats a range" "StylishHaskell" "formatted_range" $ \doc -> do + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 0 0) (Position 2 21)) + ] + +goldenWithStylishHaskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter def stylishHaskellPlugin "stylishHaskell" def title testDataDir fp desc "hs" + +testDataDir :: FilePath +testDataDir = "plugins" "hls-stylish-haskell-plugin" "test" "testdata" diff --git a/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_document.hs b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_document.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_document.hs @@ -0,0 +1,8 @@ +import Data.Char +import qualified Data.List +import Data.String + +bar :: Maybe (Either String Integer) -> Integer +bar Nothing = 0 +bar (Just (Left _)) = 0 +bar (Just (Right x)) = x diff --git a/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_range.hs b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_range.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.formatted_range.hs @@ -0,0 +1,8 @@ +import Data.Char +import qualified Data.List +import Data.String + +bar :: Maybe (Either String Integer) -> Integer +bar Nothing = 0 +bar (Just (Left _)) = 0 +bar (Just (Right x)) = x diff --git a/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/test/testdata/StylishHaskell.hs @@ -0,0 +1,8 @@ +import Data.Char +import qualified Data.List +import Data.String + +bar :: Maybe (Either String Integer) -> Integer +bar Nothing = 0 +bar (Just (Left _)) = 0 +bar (Just (Right x)) = x diff --git a/plugins/hls-stylish-haskell-plugin/test/testdata/hie.yaml b/plugins/hls-stylish-haskell-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-stylish-haskell-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module HlsPlugins where import Ide.Logger (Pretty (pretty), Recorder, diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -1,11 +1,9 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE TypeApplications #-} module Ide.Arguments ( Arguments(..) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -1,12 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Ide.Main(defaultMain, runLspMode, Log(..)) where diff --git a/test/functional/Config.hs b/test/functional/Config.hs --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Config (tests) where diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} module Progress (tests) where diff --git a/test/testdata/schema/ghc92/default-config.golden.json b/test/testdata/schema/ghc92/default-config.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc92/default-config.golden.json @@ -0,0 +1,141 @@ +{ + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { + "alternateNumberFormat": { + "globalOn": true + }, + "cabal": { + "codeActionsOn": true, + "completionOn": true, + "diagnosticsOn": true + }, + "callHierarchy": { + "globalOn": true + }, + "changeTypeSignature": { + "globalOn": true + }, + "class": { + "codeActionsOn": true, + "codeLensOn": true + }, + "eval": { + "config": { + "diff": true, + "exception": false + }, + "globalOn": true + }, + "explicit-fields": { + "globalOn": true + }, + "explicit-fixity": { + "globalOn": true + }, + "fourmolu": { + "config": { + "external": false, + "path": "fourmolu" + } + }, + "gadt": { + "globalOn": true + }, + "ghcide-code-actions-bindings": { + "globalOn": true + }, + "ghcide-code-actions-fill-holes": { + "globalOn": true + }, + "ghcide-code-actions-imports-exports": { + "globalOn": true + }, + "ghcide-code-actions-type-signatures": { + "globalOn": true + }, + "ghcide-completions": { + "config": { + "autoExtendOn": true, + "snippetsOn": true + }, + "globalOn": true + }, + "ghcide-hover-and-symbols": { + "hoverOn": true, + "symbolsOn": true + }, + "ghcide-type-lenses": { + "config": { + "mode": "always" + }, + "globalOn": true + }, + "hlint": { + "codeActionsOn": true, + "config": { + "flags": [] + }, + "diagnosticsOn": true + }, + "importLens": { + "codeActionsOn": true, + "codeLensOn": true + }, + "moduleName": { + "globalOn": true + }, + "ormolu": { + "config": { + "external": false + } + }, + "overloaded-record-dot": { + "globalOn": true + }, + "pragmas-completion": { + "globalOn": true + }, + "pragmas-disable": { + "globalOn": true + }, + "pragmas-suggest": { + "globalOn": true + }, + "qualifyImportedNames": { + "globalOn": true + }, + "rename": { + "config": { + "crossModule": false + }, + "globalOn": true + }, + "retrie": { + "globalOn": true + }, + "semanticTokens": { + "config": { + "classMethodToken": "method", + "classToken": "class", + "dataConstructorToken": "enumMember", + "functionToken": "function", + "moduleToken": "namespace", + "operatorToken": "operator", + "patternSynonymToken": "macro", + "recordFieldToken": "property", + "typeConstructorToken": "enum", + "typeFamilyToken": "interface", + "typeSynonymToken": "type", + "typeVariableToken": "typeParameter", + "variableToken": "variable" + }, + "globalOn": false + }, + "splice": { + "globalOn": true + } + } +} diff --git a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json @@ -0,0 +1,1004 @@ +{ + "haskell.plugin.alternateNumberFormat.globalOn": { + "default": true, + "description": "Enables alternateNumberFormat plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.codeActionsOn": { + "default": true, + "description": "Enables cabal code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.completionOn": { + "default": true, + "description": "Enables cabal completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.diagnosticsOn": { + "default": true, + "description": "Enables cabal diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.callHierarchy.globalOn": { + "default": true, + "description": "Enables callHierarchy plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.changeTypeSignature.globalOn": { + "default": true, + "description": "Enables changeTypeSignature plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeActionsOn": { + "default": true, + "description": "Enables class code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeLensOn": { + "default": true, + "description": "Enables class code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.diff": { + "default": true, + "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.exception": { + "default": false, + "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.globalOn": { + "default": true, + "description": "Enables eval plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.globalOn": { + "default": true, + "description": "Enables explicit-fields plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fixity.globalOn": { + "default": true, + "description": "Enables explicit-fixity plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.path": { + "default": "fourmolu", + "markdownDescription": "Set path to executable (for \"external\" mode).", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.gadt.globalOn": { + "default": true, + "description": "Enables gadt plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-bindings.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-bindings plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-fill-holes plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-imports-exports plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-type-signatures plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.autoExtendOn": { + "default": true, + "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.snippetsOn": { + "default": true, + "markdownDescription": "Inserts snippets when using code completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.globalOn": { + "default": true, + "description": "Enables ghcide-completions plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.config.mode": { + "default": "always", + "description": "Control how type lenses are shown", + "enum": [ + "always", + "exported", + "diagnostics" + ], + "enumDescriptions": [ + "Always displays type lenses of global bindings", + "Only display type lenses of exported global bindings", + "Follows error messages produced by GHC about missing signatures" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.ghcide-type-lenses.globalOn": { + "default": true, + "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.codeActionsOn": { + "default": true, + "description": "Enables hlint code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.config.flags": { + "default": [], + "markdownDescription": "Flags used by hlint", + "scope": "resource", + "type": "array" + }, + "haskell.plugin.hlint.diagnosticsOn": { + "default": true, + "description": "Enables hlint diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeActionsOn": { + "default": true, + "description": "Enables importLens code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeLensOn": { + "default": true, + "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.moduleName.globalOn": { + "default": true, + "description": "Enables moduleName plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ormolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.overloaded-record-dot.globalOn": { + "default": true, + "description": "Enables overloaded-record-dot plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-completion.globalOn": { + "default": true, + "description": "Enables pragmas-completion plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-disable.globalOn": { + "default": true, + "description": "Enables pragmas-disable plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-suggest.globalOn": { + "default": true, + "description": "Enables pragmas-suggest plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.qualifyImportedNames.globalOn": { + "default": true, + "description": "Enables qualifyImportedNames plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.config.crossModule": { + "default": false, + "markdownDescription": "Enable experimental cross-module renaming", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.globalOn": { + "default": true, + "description": "Enables rename plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.retrie.globalOn": { + "default": true, + "description": "Enables retrie plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.semanticTokens.config.classMethodToken": { + "default": "method", + "description": "LSP semantic token type to use for typeclass methods", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.classToken": { + "default": "class", + "description": "LSP semantic token type to use for typeclasses", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.dataConstructorToken": { + "default": "enumMember", + "description": "LSP semantic token type to use for data constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.functionToken": { + "default": "function", + "description": "LSP semantic token type to use for functions", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.moduleToken": { + "default": "namespace", + "description": "LSP semantic token type to use for modules", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.operatorToken": { + "default": "operator", + "description": "LSP semantic token type to use for operators", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.patternSynonymToken": { + "default": "macro", + "description": "LSP semantic token type to use for pattern synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.recordFieldToken": { + "default": "property", + "description": "LSP semantic token type to use for record fields", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeConstructorToken": { + "default": "enum", + "description": "LSP semantic token type to use for type constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeFamilyToken": { + "default": "interface", + "description": "LSP semantic token type to use for type families", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeSynonymToken": { + "default": "type", + "description": "LSP semantic token type to use for type synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeVariableToken": { + "default": "typeParameter", + "description": "LSP semantic token type to use for type variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.variableToken": { + "default": "variable", + "description": "LSP semantic token type to use for variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.globalOn": { + "default": false, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.splice.globalOn": { + "default": true, + "description": "Enables splice plugin", + "scope": "resource", + "type": "boolean" + } +} diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -0,0 +1,144 @@ +{ + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { + "alternateNumberFormat": { + "globalOn": true + }, + "cabal": { + "codeActionsOn": true, + "completionOn": true, + "diagnosticsOn": true + }, + "callHierarchy": { + "globalOn": true + }, + "changeTypeSignature": { + "globalOn": true + }, + "class": { + "codeActionsOn": true, + "codeLensOn": true + }, + "eval": { + "config": { + "diff": true, + "exception": false + }, + "globalOn": true + }, + "explicit-fields": { + "globalOn": true + }, + "explicit-fixity": { + "globalOn": true + }, + "fourmolu": { + "config": { + "external": false, + "path": "fourmolu" + } + }, + "gadt": { + "globalOn": true + }, + "ghcide-code-actions-bindings": { + "globalOn": true + }, + "ghcide-code-actions-fill-holes": { + "globalOn": true + }, + "ghcide-code-actions-imports-exports": { + "globalOn": true + }, + "ghcide-code-actions-type-signatures": { + "globalOn": true + }, + "ghcide-completions": { + "config": { + "autoExtendOn": true, + "snippetsOn": true + }, + "globalOn": true + }, + "ghcide-hover-and-symbols": { + "hoverOn": true, + "symbolsOn": true + }, + "ghcide-type-lenses": { + "config": { + "mode": "always" + }, + "globalOn": true + }, + "hlint": { + "codeActionsOn": true, + "config": { + "flags": [] + }, + "diagnosticsOn": true + }, + "importLens": { + "codeActionsOn": true, + "codeLensOn": true + }, + "moduleName": { + "globalOn": true + }, + "ormolu": { + "config": { + "external": false + } + }, + "overloaded-record-dot": { + "globalOn": true + }, + "pragmas-completion": { + "globalOn": true + }, + "pragmas-disable": { + "globalOn": true + }, + "pragmas-suggest": { + "globalOn": true + }, + "qualifyImportedNames": { + "globalOn": true + }, + "rename": { + "config": { + "crossModule": false + }, + "globalOn": true + }, + "retrie": { + "globalOn": true + }, + "semanticTokens": { + "config": { + "classMethodToken": "method", + "classToken": "class", + "dataConstructorToken": "enumMember", + "functionToken": "function", + "moduleToken": "namespace", + "operatorToken": "operator", + "patternSynonymToken": "macro", + "recordFieldToken": "property", + "typeConstructorToken": "enum", + "typeFamilyToken": "interface", + "typeSynonymToken": "type", + "typeVariableToken": "typeParameter", + "variableToken": "variable" + }, + "globalOn": false + }, + "splice": { + "globalOn": true + }, + "stan": { + "globalOn": false + } + } +} diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -0,0 +1,1010 @@ +{ + "haskell.plugin.alternateNumberFormat.globalOn": { + "default": true, + "description": "Enables alternateNumberFormat plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.codeActionsOn": { + "default": true, + "description": "Enables cabal code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.completionOn": { + "default": true, + "description": "Enables cabal completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.diagnosticsOn": { + "default": true, + "description": "Enables cabal diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.callHierarchy.globalOn": { + "default": true, + "description": "Enables callHierarchy plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.changeTypeSignature.globalOn": { + "default": true, + "description": "Enables changeTypeSignature plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeActionsOn": { + "default": true, + "description": "Enables class code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeLensOn": { + "default": true, + "description": "Enables class code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.diff": { + "default": true, + "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.exception": { + "default": false, + "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.globalOn": { + "default": true, + "description": "Enables eval plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.globalOn": { + "default": true, + "description": "Enables explicit-fields plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fixity.globalOn": { + "default": true, + "description": "Enables explicit-fixity plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.path": { + "default": "fourmolu", + "markdownDescription": "Set path to executable (for \"external\" mode).", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.gadt.globalOn": { + "default": true, + "description": "Enables gadt plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-bindings.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-bindings plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-fill-holes plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-imports-exports plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-type-signatures plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.autoExtendOn": { + "default": true, + "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.snippetsOn": { + "default": true, + "markdownDescription": "Inserts snippets when using code completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.globalOn": { + "default": true, + "description": "Enables ghcide-completions plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.config.mode": { + "default": "always", + "description": "Control how type lenses are shown", + "enum": [ + "always", + "exported", + "diagnostics" + ], + "enumDescriptions": [ + "Always displays type lenses of global bindings", + "Only display type lenses of exported global bindings", + "Follows error messages produced by GHC about missing signatures" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.ghcide-type-lenses.globalOn": { + "default": true, + "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.codeActionsOn": { + "default": true, + "description": "Enables hlint code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.config.flags": { + "default": [], + "markdownDescription": "Flags used by hlint", + "scope": "resource", + "type": "array" + }, + "haskell.plugin.hlint.diagnosticsOn": { + "default": true, + "description": "Enables hlint diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeActionsOn": { + "default": true, + "description": "Enables importLens code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeLensOn": { + "default": true, + "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.moduleName.globalOn": { + "default": true, + "description": "Enables moduleName plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ormolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.overloaded-record-dot.globalOn": { + "default": true, + "description": "Enables overloaded-record-dot plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-completion.globalOn": { + "default": true, + "description": "Enables pragmas-completion plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-disable.globalOn": { + "default": true, + "description": "Enables pragmas-disable plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-suggest.globalOn": { + "default": true, + "description": "Enables pragmas-suggest plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.qualifyImportedNames.globalOn": { + "default": true, + "description": "Enables qualifyImportedNames plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.config.crossModule": { + "default": false, + "markdownDescription": "Enable experimental cross-module renaming", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.globalOn": { + "default": true, + "description": "Enables rename plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.retrie.globalOn": { + "default": true, + "description": "Enables retrie plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.semanticTokens.config.classMethodToken": { + "default": "method", + "description": "LSP semantic token type to use for typeclass methods", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.classToken": { + "default": "class", + "description": "LSP semantic token type to use for typeclasses", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.dataConstructorToken": { + "default": "enumMember", + "description": "LSP semantic token type to use for data constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.functionToken": { + "default": "function", + "description": "LSP semantic token type to use for functions", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.moduleToken": { + "default": "namespace", + "description": "LSP semantic token type to use for modules", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.operatorToken": { + "default": "operator", + "description": "LSP semantic token type to use for operators", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.patternSynonymToken": { + "default": "macro", + "description": "LSP semantic token type to use for pattern synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.recordFieldToken": { + "default": "property", + "description": "LSP semantic token type to use for record fields", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeConstructorToken": { + "default": "enum", + "description": "LSP semantic token type to use for type constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeFamilyToken": { + "default": "interface", + "description": "LSP semantic token type to use for type families", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeSynonymToken": { + "default": "type", + "description": "LSP semantic token type to use for type synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeVariableToken": { + "default": "typeParameter", + "description": "LSP semantic token type to use for type variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.variableToken": { + "default": "variable", + "description": "LSP semantic token type to use for variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.globalOn": { + "default": false, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.splice.globalOn": { + "default": true, + "description": "Enables splice plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.stan.globalOn": { + "default": false, + "description": "Enables stan plugin", + "scope": "resource", + "type": "boolean" + } +} diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -0,0 +1,144 @@ +{ + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { + "alternateNumberFormat": { + "globalOn": true + }, + "cabal": { + "codeActionsOn": true, + "completionOn": true, + "diagnosticsOn": true + }, + "callHierarchy": { + "globalOn": true + }, + "changeTypeSignature": { + "globalOn": true + }, + "class": { + "codeActionsOn": true, + "codeLensOn": true + }, + "eval": { + "config": { + "diff": true, + "exception": false + }, + "globalOn": true + }, + "explicit-fields": { + "globalOn": true + }, + "explicit-fixity": { + "globalOn": true + }, + "fourmolu": { + "config": { + "external": false, + "path": "fourmolu" + } + }, + "gadt": { + "globalOn": true + }, + "ghcide-code-actions-bindings": { + "globalOn": true + }, + "ghcide-code-actions-fill-holes": { + "globalOn": true + }, + "ghcide-code-actions-imports-exports": { + "globalOn": true + }, + "ghcide-code-actions-type-signatures": { + "globalOn": true + }, + "ghcide-completions": { + "config": { + "autoExtendOn": true, + "snippetsOn": true + }, + "globalOn": true + }, + "ghcide-hover-and-symbols": { + "hoverOn": true, + "symbolsOn": true + }, + "ghcide-type-lenses": { + "config": { + "mode": "always" + }, + "globalOn": true + }, + "hlint": { + "codeActionsOn": true, + "config": { + "flags": [] + }, + "diagnosticsOn": true + }, + "importLens": { + "codeActionsOn": true, + "codeLensOn": true + }, + "moduleName": { + "globalOn": true + }, + "ormolu": { + "config": { + "external": false + } + }, + "overloaded-record-dot": { + "globalOn": true + }, + "pragmas-completion": { + "globalOn": true + }, + "pragmas-disable": { + "globalOn": true + }, + "pragmas-suggest": { + "globalOn": true + }, + "qualifyImportedNames": { + "globalOn": true + }, + "rename": { + "config": { + "crossModule": false + }, + "globalOn": true + }, + "retrie": { + "globalOn": true + }, + "semanticTokens": { + "config": { + "classMethodToken": "method", + "classToken": "class", + "dataConstructorToken": "enumMember", + "functionToken": "function", + "moduleToken": "namespace", + "operatorToken": "operator", + "patternSynonymToken": "macro", + "recordFieldToken": "property", + "typeConstructorToken": "enum", + "typeFamilyToken": "interface", + "typeSynonymToken": "type", + "typeVariableToken": "typeParameter", + "variableToken": "variable" + }, + "globalOn": false + }, + "splice": { + "globalOn": true + }, + "stan": { + "globalOn": false + } + } +} diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -0,0 +1,1010 @@ +{ + "haskell.plugin.alternateNumberFormat.globalOn": { + "default": true, + "description": "Enables alternateNumberFormat plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.codeActionsOn": { + "default": true, + "description": "Enables cabal code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.completionOn": { + "default": true, + "description": "Enables cabal completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.diagnosticsOn": { + "default": true, + "description": "Enables cabal diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.callHierarchy.globalOn": { + "default": true, + "description": "Enables callHierarchy plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.changeTypeSignature.globalOn": { + "default": true, + "description": "Enables changeTypeSignature plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeActionsOn": { + "default": true, + "description": "Enables class code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeLensOn": { + "default": true, + "description": "Enables class code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.diff": { + "default": true, + "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.exception": { + "default": false, + "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.globalOn": { + "default": true, + "description": "Enables eval plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.globalOn": { + "default": true, + "description": "Enables explicit-fields plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fixity.globalOn": { + "default": true, + "description": "Enables explicit-fixity plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.path": { + "default": "fourmolu", + "markdownDescription": "Set path to executable (for \"external\" mode).", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.gadt.globalOn": { + "default": true, + "description": "Enables gadt plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-bindings.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-bindings plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-fill-holes plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-imports-exports plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-type-signatures plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.autoExtendOn": { + "default": true, + "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.snippetsOn": { + "default": true, + "markdownDescription": "Inserts snippets when using code completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.globalOn": { + "default": true, + "description": "Enables ghcide-completions plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.config.mode": { + "default": "always", + "description": "Control how type lenses are shown", + "enum": [ + "always", + "exported", + "diagnostics" + ], + "enumDescriptions": [ + "Always displays type lenses of global bindings", + "Only display type lenses of exported global bindings", + "Follows error messages produced by GHC about missing signatures" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.ghcide-type-lenses.globalOn": { + "default": true, + "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.codeActionsOn": { + "default": true, + "description": "Enables hlint code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.config.flags": { + "default": [], + "markdownDescription": "Flags used by hlint", + "scope": "resource", + "type": "array" + }, + "haskell.plugin.hlint.diagnosticsOn": { + "default": true, + "description": "Enables hlint diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeActionsOn": { + "default": true, + "description": "Enables importLens code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeLensOn": { + "default": true, + "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.moduleName.globalOn": { + "default": true, + "description": "Enables moduleName plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ormolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.overloaded-record-dot.globalOn": { + "default": true, + "description": "Enables overloaded-record-dot plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-completion.globalOn": { + "default": true, + "description": "Enables pragmas-completion plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-disable.globalOn": { + "default": true, + "description": "Enables pragmas-disable plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-suggest.globalOn": { + "default": true, + "description": "Enables pragmas-suggest plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.qualifyImportedNames.globalOn": { + "default": true, + "description": "Enables qualifyImportedNames plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.config.crossModule": { + "default": false, + "markdownDescription": "Enable experimental cross-module renaming", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.globalOn": { + "default": true, + "description": "Enables rename plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.retrie.globalOn": { + "default": true, + "description": "Enables retrie plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.semanticTokens.config.classMethodToken": { + "default": "method", + "description": "LSP semantic token type to use for typeclass methods", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.classToken": { + "default": "class", + "description": "LSP semantic token type to use for typeclasses", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.dataConstructorToken": { + "default": "enumMember", + "description": "LSP semantic token type to use for data constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.functionToken": { + "default": "function", + "description": "LSP semantic token type to use for functions", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.moduleToken": { + "default": "namespace", + "description": "LSP semantic token type to use for modules", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.operatorToken": { + "default": "operator", + "description": "LSP semantic token type to use for operators", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.patternSynonymToken": { + "default": "macro", + "description": "LSP semantic token type to use for pattern synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.recordFieldToken": { + "default": "property", + "description": "LSP semantic token type to use for record fields", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeConstructorToken": { + "default": "enum", + "description": "LSP semantic token type to use for type constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeFamilyToken": { + "default": "interface", + "description": "LSP semantic token type to use for type families", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeSynonymToken": { + "default": "type", + "description": "LSP semantic token type to use for type synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeVariableToken": { + "default": "typeParameter", + "description": "LSP semantic token type to use for type variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.variableToken": { + "default": "variable", + "description": "LSP semantic token type to use for variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.globalOn": { + "default": false, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.splice.globalOn": { + "default": true, + "description": "Enables splice plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.stan.globalOn": { + "default": false, + "description": "Enables stan plugin", + "scope": "resource", + "type": "boolean" + } +} diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -0,0 +1,137 @@ +{ + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { + "alternateNumberFormat": { + "globalOn": true + }, + "cabal": { + "codeActionsOn": true, + "completionOn": true, + "diagnosticsOn": true + }, + "callHierarchy": { + "globalOn": true + }, + "changeTypeSignature": { + "globalOn": true + }, + "class": { + "codeActionsOn": true, + "codeLensOn": true + }, + "eval": { + "config": { + "diff": true, + "exception": false + }, + "globalOn": true + }, + "explicit-fields": { + "globalOn": true + }, + "explicit-fixity": { + "globalOn": true + }, + "fourmolu": { + "config": { + "external": false, + "path": "fourmolu" + } + }, + "gadt": { + "globalOn": true + }, + "ghcide-code-actions-bindings": { + "globalOn": true + }, + "ghcide-code-actions-fill-holes": { + "globalOn": true + }, + "ghcide-code-actions-imports-exports": { + "globalOn": true + }, + "ghcide-code-actions-type-signatures": { + "globalOn": true + }, + "ghcide-completions": { + "config": { + "autoExtendOn": true, + "snippetsOn": true + }, + "globalOn": true + }, + "ghcide-hover-and-symbols": { + "hoverOn": true, + "symbolsOn": true + }, + "ghcide-type-lenses": { + "config": { + "mode": "always" + }, + "globalOn": true + }, + "importLens": { + "codeActionsOn": true, + "codeLensOn": true + }, + "moduleName": { + "globalOn": true + }, + "ormolu": { + "config": { + "external": false + } + }, + "overloaded-record-dot": { + "globalOn": true + }, + "pragmas-completion": { + "globalOn": true + }, + "pragmas-disable": { + "globalOn": true + }, + "pragmas-suggest": { + "globalOn": true + }, + "qualifyImportedNames": { + "globalOn": true + }, + "rename": { + "config": { + "crossModule": false + }, + "globalOn": true + }, + "retrie": { + "globalOn": true + }, + "semanticTokens": { + "config": { + "classMethodToken": "method", + "classToken": "class", + "dataConstructorToken": "enumMember", + "functionToken": "function", + "moduleToken": "namespace", + "operatorToken": "operator", + "patternSynonymToken": "macro", + "recordFieldToken": "property", + "typeConstructorToken": "enum", + "typeFamilyToken": "interface", + "typeSynonymToken": "type", + "typeVariableToken": "typeParameter", + "variableToken": "variable" + }, + "globalOn": false + }, + "splice": { + "globalOn": true + }, + "stan": { + "globalOn": false + } + } +} diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -0,0 +1,992 @@ +{ + "haskell.plugin.alternateNumberFormat.globalOn": { + "default": true, + "description": "Enables alternateNumberFormat plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.codeActionsOn": { + "default": true, + "description": "Enables cabal code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.completionOn": { + "default": true, + "description": "Enables cabal completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.diagnosticsOn": { + "default": true, + "description": "Enables cabal diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.callHierarchy.globalOn": { + "default": true, + "description": "Enables callHierarchy plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.changeTypeSignature.globalOn": { + "default": true, + "description": "Enables changeTypeSignature plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeActionsOn": { + "default": true, + "description": "Enables class code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeLensOn": { + "default": true, + "description": "Enables class code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.diff": { + "default": true, + "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.exception": { + "default": false, + "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.globalOn": { + "default": true, + "description": "Enables eval plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.globalOn": { + "default": true, + "description": "Enables explicit-fields plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fixity.globalOn": { + "default": true, + "description": "Enables explicit-fixity plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.fourmolu.config.path": { + "default": "fourmolu", + "markdownDescription": "Set path to executable (for \"external\" mode).", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.gadt.globalOn": { + "default": true, + "description": "Enables gadt plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-bindings.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-bindings plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-fill-holes plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-imports-exports plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": { + "default": true, + "description": "Enables ghcide-code-actions-type-signatures plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.autoExtendOn": { + "default": true, + "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.snippetsOn": { + "default": true, + "markdownDescription": "Inserts snippets when using code completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.globalOn": { + "default": true, + "description": "Enables ghcide-completions plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.config.mode": { + "default": "always", + "description": "Control how type lenses are shown", + "enum": [ + "always", + "exported", + "diagnostics" + ], + "enumDescriptions": [ + "Always displays type lenses of global bindings", + "Only display type lenses of exported global bindings", + "Follows error messages produced by GHC about missing signatures" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.ghcide-type-lenses.globalOn": { + "default": true, + "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeActionsOn": { + "default": true, + "description": "Enables importLens code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeLensOn": { + "default": true, + "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.moduleName.globalOn": { + "default": true, + "description": "Enables moduleName plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ormolu.config.external": { + "default": false, + "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.overloaded-record-dot.globalOn": { + "default": true, + "description": "Enables overloaded-record-dot plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-completion.globalOn": { + "default": true, + "description": "Enables pragmas-completion plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-disable.globalOn": { + "default": true, + "description": "Enables pragmas-disable plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-suggest.globalOn": { + "default": true, + "description": "Enables pragmas-suggest plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.qualifyImportedNames.globalOn": { + "default": true, + "description": "Enables qualifyImportedNames plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.config.crossModule": { + "default": false, + "markdownDescription": "Enable experimental cross-module renaming", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.rename.globalOn": { + "default": true, + "description": "Enables rename plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.retrie.globalOn": { + "default": true, + "description": "Enables retrie plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.semanticTokens.config.classMethodToken": { + "default": "method", + "description": "LSP semantic token type to use for typeclass methods", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.classToken": { + "default": "class", + "description": "LSP semantic token type to use for typeclasses", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.dataConstructorToken": { + "default": "enumMember", + "description": "LSP semantic token type to use for data constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.functionToken": { + "default": "function", + "description": "LSP semantic token type to use for functions", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.moduleToken": { + "default": "namespace", + "description": "LSP semantic token type to use for modules", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.operatorToken": { + "default": "operator", + "description": "LSP semantic token type to use for operators", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.patternSynonymToken": { + "default": "macro", + "description": "LSP semantic token type to use for pattern synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.recordFieldToken": { + "default": "property", + "description": "LSP semantic token type to use for record fields", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeConstructorToken": { + "default": "enum", + "description": "LSP semantic token type to use for type constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeFamilyToken": { + "default": "interface", + "description": "LSP semantic token type to use for type families", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeSynonymToken": { + "default": "type", + "description": "LSP semantic token type to use for type synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeVariableToken": { + "default": "typeParameter", + "description": "LSP semantic token type to use for type variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.variableToken": { + "default": "variable", + "description": "LSP semantic token type to use for variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.globalOn": { + "default": false, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.splice.globalOn": { + "default": true, + "description": "Enables splice plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.stan.globalOn": { + "default": false, + "description": "Enables stan plugin", + "scope": "resource", + "type": "boolean" + } +}