From 54c693e81c0a542b59089a7d1ea59e2ca70caa25 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 5 Jan 2022 18:44:31 +0800 Subject: [PATCH 01/19] add selection range support --- .github/workflows/hackage.yml | 2 +- cabal.project | 19 ++ exe/Plugins.hs | 7 + .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 12 +- haskell-language-server.cabal | 11 + hls-plugin-api/src/Ide/Plugin/Config.hs | 86 ++++---- hls-plugin-api/src/Ide/Types.hs | 4 + plugins/hls-selection-range-plugin/LICENSE | 201 ++++++++++++++++++ .../hls-selection-range-plugin.cabal | 58 +++++ .../src/Ide/Plugin/SelectionRange.hs | 95 +++++++++ .../hls-selection-range-plugin/test/Main.hs | 51 +++++ .../test/testdata/MultiPositions.golden.txt | 3 + .../test/testdata/MultiPositions.hs | 10 + .../test/testdata/hie.yaml | 4 + stack-8.10.6.yaml | 9 +- stack-8.10.7.yaml | 9 +- stack-8.6.5.yaml | 9 +- stack-8.8.4.yaml | 9 +- stack-9.0.1.yaml | 9 +- stack.yaml | 10 +- 20 files changed, 552 insertions(+), 66 deletions(-) create mode 100644 plugins/hls-selection-range-plugin/LICENSE create mode 100644 plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal create mode 100644 plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs create mode 100644 plugins/hls-selection-range-plugin/test/Main.hs create mode 100644 plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt create mode 100644 plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs create mode 100644 plugins/hls-selection-range-plugin/test/testdata/hie.yaml diff --git a/.github/workflows/hackage.yml b/.github/workflows/hackage.yml index 56e2acb724..76b90576f8 100644 --- a/.github/workflows/hackage.yml +++ b/.github/workflows/hackage.yml @@ -32,7 +32,7 @@ jobs: "hls-refine-imports-plugin", "hls-retrie-plugin", "hls-splice-plugin", "hls-tactics-plugin", "hls-call-hierarchy-plugin", "hls-alternate-number-format-plugin", - "hls-qualify-imported-names-plugin", + "hls-qualify-imported-names-plugin", "hls-selection-range-plugin", "haskell-language-server"] ghc: [ "9.0.1", "8.10.7", diff --git a/cabal.project b/cabal.project index ab23e1f453..0bb9f47d85 100644 --- a/cabal.project +++ b/cabal.project @@ -26,6 +26,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-qualify-imported-names-plugin + ./plugins/hls-selection-range-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script @@ -38,6 +39,24 @@ package * ghc-options: -haddock test-show-details: direct +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-test + write-ghc-environment-files: never index-state: 2022-01-10T17:57:05Z diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 4974677877..3934b61de8 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -72,6 +72,10 @@ import Ide.Plugin.Splice as Splice import Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat #endif +#if selectionRange +import Ide.Plugin.SelectionRange as SelectionRange +#endif + -- formatters #if floskell @@ -167,6 +171,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #endif #if alternateNumberFormat AlternateNumberFormat.descriptor "alternateNumberFormat" : +#endif +#if selectionRange + SelectionRange.descriptor "selectionRange" : #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index c854330d9c..ab227029c6 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,15 +9,15 @@ module Development.IDE.Plugin.HLS.GhcIde import Control.Monad.IO.Class import Development.IDE import Development.IDE.LSP.HoverDefinition -import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline -import qualified Development.IDE.Plugin.CodeAction as CodeAction -import qualified Development.IDE.Plugin.Completions as Completions -import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import qualified Development.IDE.Plugin.CodeAction as CodeAction +import qualified Development.IDE.Plugin.Completions as Completions +import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types -import Language.LSP.Server (LspM) +import Language.LSP.Server (LspM) import Language.LSP.Types -import Text.Regex.TDFA.Text () +import Text.Regex.TDFA.Text () descriptors :: [PluginDescriptor IdeState] descriptors = diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4dc41b4d09..5e3825f0e7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -173,6 +173,11 @@ flag qualifyImportedNames default: True manual: True +flag selectionRange + description: Enable selectionRange plugin + default: True + manual: True + -- formatters flag floskell @@ -280,6 +285,11 @@ common qualifyImportedNames build-depends: hls-qualify-imported-names-plugin ^>=1.0.0.0 cpp-options: -DqualifyImportedNames +common selectionRange + if flag(selectionRange) + build-depends: hls-selection-range-plugin ^>=1.0.0.0 + cpp-options: -DselectionRange + -- formatters common floskell @@ -329,6 +339,7 @@ executable haskell-language-server , splice , alternateNumberFormat , qualifyImportedNames + , selectionRange , floskell , fourmolu , ormolu diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 00dcb4b335..8aaafd9849 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -100,58 +100,62 @@ instance A.ToJSON Config where -- This provides a regular naming scheme for all plugin config. data PluginConfig = PluginConfig - { plcGlobalOn :: !Bool - , plcCallHierarchyOn :: !Bool - , plcCodeActionsOn :: !Bool - , plcCodeLensOn :: !Bool - , plcDiagnosticsOn :: !Bool - , plcHoverOn :: !Bool - , plcSymbolsOn :: !Bool - , plcCompletionOn :: !Bool - , plcRenameOn :: !Bool - , plcConfig :: !A.Object + { plcGlobalOn :: !Bool + , plcCallHierarchyOn :: !Bool + , plcCodeActionsOn :: !Bool + , plcCodeLensOn :: !Bool + , plcDiagnosticsOn :: !Bool + , plcHoverOn :: !Bool + , plcSymbolsOn :: !Bool + , plcCompletionOn :: !Bool + , plcRenameOn :: !Bool + , plcSelectionRangeOn :: !Bool + , plcConfig :: !A.Object } deriving (Show,Eq) instance Default PluginConfig where def = PluginConfig - { plcGlobalOn = True - , plcCallHierarchyOn = True - , plcCodeActionsOn = True - , plcCodeLensOn = True - , plcDiagnosticsOn = True - , plcHoverOn = True - , plcSymbolsOn = True - , plcCompletionOn = True - , plcRenameOn = True - , plcConfig = mempty + { plcGlobalOn = True + , plcCallHierarchyOn = True + , plcCodeActionsOn = True + , plcCodeLensOn = True + , plcDiagnosticsOn = True + , plcHoverOn = True + , plcSymbolsOn = True + , plcCompletionOn = True + , plcRenameOn = True + , plcSelectionRangeOn = True + , plcConfig = mempty } instance A.ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn cfg) = r + toJSON (PluginConfig g ch ca cl d h s c rn sr cfg) = r where - r = object [ "globalOn" .= g - , "callHierarchyOn" .= ch - , "codeActionsOn" .= ca - , "codeLensOn" .= cl - , "diagnosticsOn" .= d - , "hoverOn" .= h - , "symbolsOn" .= s - , "completionOn" .= c - , "renameOn" .= rn - , "config" .= cfg + r = object [ "globalOn" .= g + , "callHierarchyOn" .= ch + , "codeActionsOn" .= ca + , "codeLensOn" .= cl + , "diagnosticsOn" .= d + , "hoverOn" .= h + , "symbolsOn" .= s + , "completionOn" .= c + , "renameOn" .= rn + , "selectionRangeOn" .= sr + , "config" .= cfg ] instance A.FromJSON PluginConfig where parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig - <$> o .:? "globalOn" .!= plcGlobalOn def - <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def - <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def - <*> o .:? "codeLensOn" .!= plcCodeLensOn def - <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ - <*> o .:? "hoverOn" .!= plcHoverOn def - <*> o .:? "symbolsOn" .!= plcSymbolsOn def - <*> o .:? "completionOn" .!= plcCompletionOn def - <*> o .:? "renameOn" .!= plcRenameOn def - <*> o .:? "config" .!= plcConfig def + <$> o .:? "globalOn" .!= plcGlobalOn def + <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def + <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def + <*> o .:? "codeLensOn" .!= plcCodeLensOn def + <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ + <*> o .:? "hoverOn" .!= plcHoverOn def + <*> o .:? "symbolsOn" .!= plcSymbolsOn def + <*> o .:? "completionOn" .!= plcCompletionOn def + <*> o .:? "renameOn" .!= plcRenameOn def + <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def + <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index b20eb890d6..954776a2d4 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -284,6 +284,10 @@ instance PluginMethod TextDocumentRangeFormatting where instance PluginMethod TextDocumentPrepareCallHierarchy where pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn +instance PluginMethod TextDocumentSelectionRange where + pluginEnabled _ = pluginEnabledConfig plcSelectionRangeOn + combineResponses _ _ _ _ (x :| _) = x + instance PluginMethod CallHierarchyIncomingCalls where pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn diff --git a/plugins/hls-selection-range-plugin/LICENSE b/plugins/hls-selection-range-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-selection-range-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal new file mode 100644 index 0000000000..423e19f6e0 --- /dev/null +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -0,0 +1,58 @@ +cabal-version: 2.4 +name: hls-selection-range-plugin +version: 1.0.0.0 +synopsis: + HLS Plugin to support smart selection range + +description: + Please see the README on GitHub at + +license: Apache-2.0 +license-file: LICENSE +author: + https://github.com/haskell/haskell-language-server/contributors + +maintainer: + https://github.com/haskell/haskell-language-server/contributors + +category: Development +build-type: Simple +extra-source-files: + LICENSE + +library + exposed-modules: + Ide.Plugin.SelectionRange + + ghc-options: -Wall + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , ghcide ^>=1.5.0 + , hls-plugin-api >=1.1 && <1.3 + , lsp + , transformers + , mtl + , text + + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , containers + , filepath + , hls-selection-range-plugin + , hls-test-utils >=1.0 && <1.2 + , lsp + , lsp-test + , text + , bytestring + , lens diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs new file mode 100644 index 0000000000..56eb3ca277 --- /dev/null +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.SelectionRange (descriptor) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + runMaybeT) +import Data.Foldable (find) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Development.IDE (GetHieAst (GetHieAst), + HieAstResult (HAR, hieAst), + IdeAction, + IdeState (shakeExtras), + Range (Range), + fromNormalizedFilePath, + realSrcSpanToRange, + runIdeAction, + toNormalizedFilePath', + uriToFilePath') +import Development.IDE.Core.Actions (useE) +import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentPosition, + toCurrentRange) +import Development.IDE.GHC.Compat (HieAST (Node), Span, + getAsts) +import Development.IDE.GHC.Compat.Util (mkFastString) +import Ide.Types (PluginDescriptor (pluginHandlers), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Server (LspM) +import Language.LSP.Types (List (List), + NormalizedFilePath, + Position, ResponseError, + SMethod (STextDocumentSelectionRange), + SelectionRange (..), + SelectionRangeParams (..), + TextDocumentIdentifier (TextDocumentIdentifier)) +import Prelude hiding (span) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + } + +selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) +selectionRangeHandler ide _ SelectionRangeParams{..} = do + let (TextDocumentIdentifier uri) = _textDocument + let filePathMaybe = toNormalizedFilePath' <$> uriToFilePath' uri + case filePathMaybe of + Nothing -> pure . Right . List $ [] + Just filePath -> liftIO $ do + let (List positions) = _positions + selectionRanges <- runIdeAction "SelectionRange" (shakeExtras ide) $ getSelectionRanges filePath positions + pure . Right . List $ selectionRanges + +getSelectionRanges :: NormalizedFilePath -> [Position] -> IdeAction [SelectionRange] +getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do + (HAR{hieAst}, positionMapping) <- useE GetHieAst file + positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions + ast <- MaybeT . pure $ getAsts hieAst Map.!? (mkFastString . fromNormalizedFilePath) file + MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ + findSelectionRangesByPositions (astPathsLeafToRoot ast) positions' + +-- | Like '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 + } + +-- | Build all paths from ast leaf to root +astPathsLeafToRoot :: HieAST a -> [SelectionRange] +astPathsLeafToRoot = mapMaybe spansToSelectionRange . go [[]] + where + go acc (Node _ span []) = fmap (span:) acc + go acc (Node _ span children) = concatMap (go (fmap (span:) acc)) children + +spansToSelectionRange :: [Span] -> Maybe SelectionRange +spansToSelectionRange [] = Nothing +spansToSelectionRange (span:spans) = Just $ + SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} + +findSelectionRangesByPositions :: [SelectionRange] -> [Position] -> [SelectionRange] +findSelectionRangesByPositions selectionRanges = fmap findByPosition + where + findByPosition p = fromMaybe SelectionRange{_range = Range p p, _parent = Nothing} $ + find (isPositionInSelectionRange p) selectionRanges + isPositionInSelectionRange p SelectionRange{_range} = + let Range sp ep = _range in sp <= p && p <= ep diff --git a/plugins/hls-selection-range-plugin/test/Main.hs b/plugins/hls-selection-range-plugin/test/Main.hs new file mode 100644 index 0000000000..880f758366 --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/Main.hs @@ -0,0 +1,51 @@ +{-# 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.SelectionRange (descriptor) +import Language.LSP.Types.Lens +import System.FilePath ((<.>), ()) +import Test.Hls + +plugin :: PluginDescriptor IdeState +plugin = descriptor "selectionRange" + +main :: IO () +main = defaultTestRunner $ + testGroup "Selection Range" + [ goldenTest "MultiPositions" [(4, 36), (8, 10), (1, 8)] + ] + +-- | build a golden test for +goldenTest :: TestName -> [(UInt, UInt)] -> TestTree +goldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer plugin testDataDir $ do + doc <- openDoc (testName <.> "hs") "haskell" + resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) + let res = resp ^. result + pure $ fmap showSelectionRangesForTest res + case res of + Left err -> assertFailure (show err) + Right golden -> pure golden + +testDataDir :: FilePath +testDataDir = "test" "testdata" + +showSelectionRangesForTest :: List SelectionRange -> ByteString +showSelectionRangesForTest (List 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 diff --git a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt new file mode 100644 index 0000000000..8811a21545 --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt @@ -0,0 +1,3 @@ +(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (10,17) +(8,10) (8,12) => (8,8) (8,14) => (8,5) (10,17) => (7,14) (10,17) => (7,1) (10,17) => (3,1) (10,17) +(1,8) (1,8) \ No newline at end of file diff --git a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs new file mode 100644 index 0000000000..eb7a8d77d3 --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs @@ -0,0 +1,10 @@ +module MultiPositions where + +import Data.List (find) +import qualified Data.Foldable (foldl, foldl') + +someFunc :: Int -> String -> (Int, String) +someFunc x y = + if x >= 0 + then (42, y) + else (43, y) diff --git a/plugins/hls-selection-range-plugin/test/testdata/hie.yaml b/plugins/hls-selection-range-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..e2799dc09a --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "A" diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index 6863e2a43c..b650fccab1 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -46,9 +46,12 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - lsp-1.4.0.0 - - lsp-test-0.14.0.2 - - lsp-types-1.4.0.0 + - git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 804a9ad284..305e3baba4 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -47,9 +47,12 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - lsp-1.4.0.0 - - lsp-test-0.14.0.2 - - lsp-types-1.4.0.0 + - git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 088f1d4149..02c9eb4265 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -104,9 +104,12 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 - - lsp-1.4.0.0 - - lsp-test-0.14.0.2 - - lsp-types-1.4.0.0 + - git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test - mod-0.1.2.2 - semirings-0.6 - stm-containers-1.1.0.4 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 5e63618afe..b9dbdc83ea 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -80,9 +80,12 @@ extra-deps: - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - lsp-1.4.0.0 - - lsp-test-0.14.0.2 - - lsp-types-1.4.0.0 + - git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test - stm-containers-1.1.0.4 - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 - primitive-extras-0.10.1 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 755bfae10d..51867b6ec9 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -50,9 +50,12 @@ extra-deps: - monad-dijkstra-0.1.1.3 - multistate-0.8.0.3 - retrie-1.1.0.0 -- lsp-1.4.0.0 -- lsp-test-0.14.0.2 -- lsp-types-1.4.0.0 +- git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test # shake-bench dependencies - Chart-1.9.3 diff --git a/stack.yaml b/stack.yaml index 804a9ad284..5f714ffe3b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-selection-range-plugin ghc-options: "$everything": -haddock @@ -47,9 +48,12 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - lsp-1.4.0.0 - - lsp-test-0.14.0.2 - - lsp-types-1.4.0.0 + - git: https://github.com/haskell/lsp.git + commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdirs: + - lsp + - lsp-types + - lsp-test - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 From 4567bf86363ea865e9505ca2f24f5c684023647f Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 15 Jan 2022 17:28:25 +0800 Subject: [PATCH 02/19] add the whole import area as a selection step --- .../hls-selection-range-plugin.cabal | 2 + .../src/Ide/Plugin/SelectionRange.hs | 88 +++++++++++-------- .../Plugin/SelectionRange/ASTPreProcess.hs | 40 +++++++++ .../test/testdata/MultiPositions.golden.txt | 2 +- 4 files changed, 94 insertions(+), 38 deletions(-) create mode 100644 plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal index 423e19f6e0..e753ca563e 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -23,6 +23,8 @@ extra-source-files: library exposed-modules: Ide.Plugin.SelectionRange + other-modules: + Ide.Plugin.SelectionRange.ASTPreProcess ghc-options: -Wall hs-source-dirs: src diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 56eb3ca277..1b467b51f2 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -4,42 +4,49 @@ module Ide.Plugin.SelectionRange (descriptor) where -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), - runMaybeT) -import Data.Foldable (find) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Development.IDE (GetHieAst (GetHieAst), - HieAstResult (HAR, hieAst), - IdeAction, - IdeState (shakeExtras), - Range (Range), - fromNormalizedFilePath, - realSrcSpanToRange, - runIdeAction, - toNormalizedFilePath', - uriToFilePath') -import Development.IDE.Core.Actions (useE) -import Development.IDE.Core.PositionMapping (PositionMapping, - fromCurrentPosition, - toCurrentRange) -import Development.IDE.GHC.Compat (HieAST (Node), Span, - getAsts) -import Development.IDE.GHC.Compat.Util (mkFastString) -import Ide.Types (PluginDescriptor (pluginHandlers), - PluginId, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), - NormalizedFilePath, - Position, ResponseError, - SMethod (STextDocumentSelectionRange), - SelectionRange (..), - SelectionRangeParams (..), - TextDocumentIdentifier (TextDocumentIdentifier)) -import Prelude hiding (span) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (MonadReader (ask)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + runMaybeT) +import Data.Foldable (find) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import Development.IDE (GetHieAst (GetHieAst), + HieAstResult (HAR, hieAst), + IdeAction, + IdeState (shakeExtras), + Range (Range), + fromNormalizedFilePath, + logDebug, + realSrcSpanToRange, + runIdeAction, + toNormalizedFilePath', + uriToFilePath') +import Development.IDE.Core.Actions (useE) +import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentPosition, + toCurrentRange) +import Development.IDE.Core.Shake (ShakeExtras (ShakeExtras, logger)) +import Development.IDE.GHC.Compat (HieAST (Node, nodeChildren, nodeInfo), + NodeInfo (nodeAnnotations), + Span, getAsts) +import Development.IDE.GHC.Compat.Util (mkFastString) +import Ide.Plugin.SelectionRange.ASTPreProcess (preProcessAST) +import Ide.Types (PluginDescriptor (pluginHandlers), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Server (LspM) +import Language.LSP.Types (List (List), + NormalizedFilePath, + Position, + ResponseError, + SMethod (STextDocumentSelectionRange), + SelectionRange (..), + SelectionRangeParams (..), + TextDocumentIdentifier (TextDocumentIdentifier)) +import Prelude hiding (span) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -62,8 +69,15 @@ getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do (HAR{hieAst}, positionMapping) <- useE GetHieAst file positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions ast <- MaybeT . pure $ getAsts hieAst Map.!? (mkFastString . fromNormalizedFilePath) file + + -- FIXME: remove the debug logs when it's done + ShakeExtras{logger} <- ask + let children = nodeAnnotations . nodeInfo <$> nodeChildren ast + liftIO $ logDebug logger $ "children: " <> T.pack (show children) + + let ast' = preProcessAST ast MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ - findSelectionRangesByPositions (astPathsLeafToRoot ast) positions' + findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' -- | Like 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs new file mode 100644 index 0000000000..334c2cfe39 --- /dev/null +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Plugin.SelectionRange.ASTPreProcess + ( preProcessAST + ) where + +import Data.List (groupBy) +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Development.IDE.GHC.Compat (HieAST (..), + NodeInfo (NodeInfo, nodeAnnotations), + mkRealSrcSpan, realSrcSpanEnd, + realSrcSpanStart) +import Development.IDE.GHC.Compat.Util (mkFastString) + +-- | Make the AST more suitable for generating selection range. +preProcessAST :: HieAST a -> HieAST a +preProcessAST = mergeImports + +mergeImports :: HieAST a -> HieAST a +mergeImports node = node { nodeChildren = children } + where + children = mapMaybe merge + . groupBy (\x y -> nodeIsImport x && nodeIsImport y) + . nodeChildren $ node + + merge [] = Nothing + merge [x] = Just x + merge xs = Just (createVirtualNode xs) + +nodeIsImport :: HieAST a -> Bool +nodeIsImport node = Set.member (mkFastString "ImportDecl", mkFastString "ImportDecl") annotations + where + annotations = nodeAnnotations . nodeInfo $ node + +createVirtualNode :: [HieAST a] -> HieAST a +createVirtualNode nodes = Node (NodeInfo mempty mempty mempty) span' nodes + where + span' = mkRealSrcSpan (minimum locations) (maximum locations) + locations = (\s -> [realSrcSpanStart s, realSrcSpanEnd s]) . nodeSpan =<< nodes diff --git a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt index 8811a21545..fe705e48fb 100644 --- a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt +++ b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt @@ -1,3 +1,3 @@ -(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (10,17) +(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47) => (3,1) (10,17) (8,10) (8,12) => (8,8) (8,14) => (8,5) (10,17) => (7,14) (10,17) => (7,1) (10,17) => (3,1) (10,17) (1,8) (1,8) \ No newline at end of file From 660c6419d23b845ebf7ddea9f005bbdf8fb24ad9 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sun, 16 Jan 2022 20:07:49 +0800 Subject: [PATCH 03/19] add selection range plugin to all project files --- .github/workflows/test.yml | 4 ++++ cabal-ghc901.project | 1 + cabal-ghc921.project | 1 + stack-8.10.6.yaml | 1 + stack-8.10.7.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.4.yaml | 1 + stack-9.0.1.yaml | 1 + stack-9.2.1.yaml | 1 + 9 files changed, 12 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 59578a98a0..83f53ca8ea 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -222,6 +222,10 @@ jobs: name: Test hls-qualify-imported-names-plugin test suite run: cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" || cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" + - if: matrix.test + name: Test hls-selection-range-plugin test suite + run: cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" || cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/cabal-ghc901.project b/cabal-ghc901.project index fce2492f87..58597ae692 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -26,6 +26,7 @@ packages: ./plugins/hls-ormolu-plugin ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin + ./plugins/hls-selection-range-plugin with-compiler: ghc-9.0.1 diff --git a/cabal-ghc921.project b/cabal-ghc921.project index e51bc3a1f5..bcd0e8f477 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -26,6 +26,7 @@ packages: ./plugins/hls-ormolu-plugin ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin + ./plugins/hls-selection-range-plugin repository head.hackage.ghc.haskell.org url: https://ghc.gitlab.haskell.org/head.hackage/ diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index b650fccab1..09bd4641f0 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -30,6 +30,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-selection-range-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 305e3baba4..5f714ffe3b 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -31,6 +31,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-selection-range-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 02c9eb4265..c03c7d0162 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -28,6 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-selection-range-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index b9dbdc83ea..957067eedd 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -28,6 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-selection-range-plugin ghc-options: "$everything": -haddock diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 51867b6ec9..6dda41d6bf 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -28,6 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin +- ./plugins/hls-selection-range-plugin extra-deps: - aeson-2.0.2.0 diff --git a/stack-9.2.1.yaml b/stack-9.2.1.yaml index 690e8a1a03..a2c6ceb7cf 100644 --- a/stack-9.2.1.yaml +++ b/stack-9.2.1.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-module-name-plugin # - ./plugins/hls-ormolu-plugin # - ./plugins/hls-alternate-number-format-plugin +- ./plugins/hls-selection-range-plugin extra-deps: From 3e39bfc6006257ed4ee9945c0ea9c129a303f395 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 19 Jan 2022 18:02:46 +0800 Subject: [PATCH 04/19] merge type signature with value definition --- .../hls-selection-range-plugin.cabal | 5 +- .../src/Ide/Plugin/SelectionRange.hs | 32 ++++---- .../Plugin/SelectionRange/ASTPreProcess.hs | 80 ++++++++++++++++--- .../hls-selection-range-plugin/test/Main.hs | 3 +- .../test/testdata/Function.golden.txt | 4 + .../test/testdata/Function.hs | 14 ++++ .../test/testdata/Import.golden.txt | 2 + .../test/testdata/Import.hs | 4 + .../test/testdata/MultiPositions.golden.txt | 3 - .../test/testdata/MultiPositions.hs | 10 --- 10 files changed, 113 insertions(+), 44 deletions(-) create mode 100644 plugins/hls-selection-range-plugin/test/testdata/Function.golden.txt create mode 100644 plugins/hls-selection-range-plugin/test/testdata/Function.hs create mode 100644 plugins/hls-selection-range-plugin/test/testdata/Import.golden.txt create mode 100644 plugins/hls-selection-range-plugin/test/testdata/Import.hs delete mode 100644 plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt delete mode 100644 plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal index e753ca563e..dad0d012e3 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -25,9 +25,9 @@ library Ide.Plugin.SelectionRange other-modules: Ide.Plugin.SelectionRange.ASTPreProcess - ghc-options: -Wall hs-source-dirs: src + default-language: Haskell2010 build-depends: , aeson , base >=4.12 && <5 @@ -38,8 +38,7 @@ library , transformers , mtl , text - - default-language: Haskell2010 + , extra test-suite tests type: exitcode-stdio-1.0 diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 1b467b51f2..9efc2b87cb 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -5,20 +5,18 @@ module Ide.Plugin.SelectionRange (descriptor) where import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (MonadReader (ask)) +import Control.Monad.Reader (runReader) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Data.Foldable (find) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Text as T import Development.IDE (GetHieAst (GetHieAst), - HieAstResult (HAR, hieAst), + HieAstResult (HAR, hieAst, refMap), IdeAction, IdeState (shakeExtras), Range (Range), fromNormalizedFilePath, - logDebug, realSrcSpanToRange, runIdeAction, toNormalizedFilePath', @@ -27,12 +25,11 @@ import Development.IDE.Core.Actions (useE) import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) -import Development.IDE.Core.Shake (ShakeExtras (ShakeExtras, logger)) -import Development.IDE.GHC.Compat (HieAST (Node, nodeChildren, nodeInfo), - NodeInfo (nodeAnnotations), - Span, getAsts) +import Development.IDE.GHC.Compat (HieAST (Node), Span, + getAsts) import Development.IDE.GHC.Compat.Util (mkFastString) -import Ide.Plugin.SelectionRange.ASTPreProcess (preProcessAST) +import Ide.Plugin.SelectionRange.ASTPreProcess (PreProcessEnv (PreProcessEnv), + preProcessAST) import Ide.Types (PluginDescriptor (pluginHandlers), PluginId, defaultPluginDescriptor, @@ -66,16 +63,11 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do getSelectionRanges :: NormalizedFilePath -> [Position] -> IdeAction [SelectionRange] getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do - (HAR{hieAst}, positionMapping) <- useE GetHieAst file + (HAR{hieAst, refMap}, positionMapping) <- useE GetHieAst file positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions ast <- MaybeT . pure $ getAsts hieAst Map.!? (mkFastString . fromNormalizedFilePath) file - -- FIXME: remove the debug logs when it's done - ShakeExtras{logger} <- ask - let children = nodeAnnotations . nodeInfo <$> nodeChildren ast - liftIO $ logDebug logger $ "children: " <> T.pack (show children) - - let ast' = preProcessAST ast + let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' @@ -90,7 +82,7 @@ toCurrentSelectionRange positionMapping SelectionRange{..} = do -- | Build all paths from ast leaf to root astPathsLeafToRoot :: HieAST a -> [SelectionRange] -astPathsLeafToRoot = mapMaybe spansToSelectionRange . go [[]] +astPathsLeafToRoot = mapMaybe (spansToSelectionRange . simplifySpans) . go [[]] where go acc (Node _ span []) = fmap (span:) acc go acc (Node _ span children) = concatMap (go (fmap (span:) acc)) children @@ -100,6 +92,12 @@ spansToSelectionRange [] = Nothing spansToSelectionRange (span:spans) = Just $ SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} +simplifySpans :: [Span] -> [Span] +simplifySpans = foldr go [] + where + go x [] = [x] + go x (y:ys) = if x == y then y:ys else x:y:ys + findSelectionRangesByPositions :: [SelectionRange] -> [Position] -> [SelectionRange] findSelectionRangesByPositions selectionRanges = fmap findByPosition where diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index 334c2cfe39..7799217d60 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -1,24 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.SelectionRange.ASTPreProcess ( preProcessAST + , PreProcessEnv(..) ) where +import Control.Monad.Reader (Reader, asks) +import Data.Foldable (find, foldl') import Data.List (groupBy) +import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import qualified Data.Set as Set -import Development.IDE.GHC.Compat (HieAST (..), - NodeInfo (NodeInfo, nodeAnnotations), +import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl, ValBind), + HieAST (..), Identifier, + IdentifierDetails (identInfo), + NodeInfo (NodeInfo, nodeAnnotations, nodeIdentifiers), + RefMap, Span, flattenAst, mkRealSrcSpan, realSrcSpanEnd, realSrcSpanStart) -import Development.IDE.GHC.Compat.Util (mkFastString) +import Development.IDE.GHC.Compat.Util (FastString) +import Prelude hiding (span) + +newtype PreProcessEnv a = PreProcessEnv + { preProcessEnvRefMap :: RefMap a + } -- | Make the AST more suitable for generating selection range. -preProcessAST :: HieAST a -> HieAST a -preProcessAST = mergeImports +preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition -mergeImports :: HieAST a -> HieAST a -mergeImports node = node { nodeChildren = children } +mergeImports :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +mergeImports node = pure $ node { nodeChildren = children } where children = mapMaybe merge . groupBy (\x y -> nodeIsImport x && nodeIsImport y) @@ -29,12 +42,59 @@ mergeImports node = node { nodeChildren = children } merge xs = Just (createVirtualNode xs) nodeIsImport :: HieAST a -> Bool -nodeIsImport node = Set.member (mkFastString "ImportDecl", mkFastString "ImportDecl") annotations - where - annotations = nodeAnnotations . nodeInfo $ node +nodeIsImport = pairInNodeAnnotations ("ImportDecl", "ImportDecl") createVirtualNode :: [HieAST a] -> HieAST a createVirtualNode nodes = Node (NodeInfo mempty mempty mempty) span' nodes where span' = mkRealSrcSpan (minimum locations) (maximum locations) locations = (\s -> [realSrcSpanStart s, realSrcSpanEnd s]) . nodeSpan =<< nodes + +mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +mergeSignatureWithDefinition node = do + refMap <- asks preProcessEnvRefMap + children' <- traverse mergeSignatureWithDefinition (nodeChildren node) + pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' } + where + go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a] + go _ [] node' = [node'] + go refMap (prev:others) node' = + case mergeNearbySigDef refMap (prev, node') of + Nothing -> node':prev:others + Just comb -> comb:others + +mergeNearbySigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) +mergeNearbySigDef refMap (n1, n2) = do + if not (("TypeSig", "Sig") `pairInNodeAnnotations` n1 && ("FunBind", "HsBindLR") `pairInNodeAnnotations` n2) + then Nothing + else do + typeSigId <- identifierForTypeSig n1 + refs <- Map.lookup typeSigId refMap + if any (isIdentADef (nodeSpan n2)) refs + then pure $ createVirtualNode [n1, n2] + else Nothing + +identifierForTypeSig :: HieAST a -> Maybe Identifier +identifierForTypeSig node = + case mapMaybe extractIdentifier nodes of + [] -> Nothing + (ident:_) -> Just ident + where + nodes = flattenAst node + extractIdentifier = fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) + . Map.toList . nodeIdentifiers . nodeInfo + +-- | is the given occurence 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 = any isContextInfoDef . Set.toList . identInfo $ detail + + isContextInfoDef ValBind{} = True + isContextInfoDef MatchBind = True + isContextInfoDef _ = False + +pairInNodeAnnotations :: (FastString, FastString) -> HieAST a -> Bool +pairInNodeAnnotations p node = p `Set.member` (nodeAnnotations . nodeInfo $ node) diff --git a/plugins/hls-selection-range-plugin/test/Main.hs b/plugins/hls-selection-range-plugin/test/Main.hs index 880f758366..ac0335a0f6 100644 --- a/plugins/hls-selection-range-plugin/test/Main.hs +++ b/plugins/hls-selection-range-plugin/test/Main.hs @@ -17,7 +17,8 @@ plugin = descriptor "selectionRange" main :: IO () main = defaultTestRunner $ testGroup "Selection Range" - [ goldenTest "MultiPositions" [(4, 36), (8, 10), (1, 8)] + [ goldenTest "Import" [(4, 36), (1, 8)] + , goldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] ] -- | build a golden test for diff --git a/plugins/hls-selection-range-plugin/test/testdata/Function.golden.txt b/plugins/hls-selection-range-plugin/test/testdata/Function.golden.txt new file mode 100644 index 0000000000..48e84dc2df --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/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) \ No newline at end of file diff --git a/plugins/hls-selection-range-plugin/test/testdata/Function.hs b/plugins/hls-selection-range-plugin/test/testdata/Function.hs new file mode 100644 index 0000000000..4df95779a0 --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/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-selection-range-plugin/test/testdata/Import.golden.txt b/plugins/hls-selection-range-plugin/test/testdata/Import.golden.txt new file mode 100644 index 0000000000..43f39edf7d --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/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) \ No newline at end of file diff --git a/plugins/hls-selection-range-plugin/test/testdata/Import.hs b/plugins/hls-selection-range-plugin/test/testdata/Import.hs new file mode 100644 index 0000000000..9159c29d49 --- /dev/null +++ b/plugins/hls-selection-range-plugin/test/testdata/Import.hs @@ -0,0 +1,4 @@ +module MultiPositions where + +import Data.List (find) +import qualified Data.Foldable (foldl, foldl') diff --git a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt deleted file mode 100644 index fe705e48fb..0000000000 --- a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.golden.txt +++ /dev/null @@ -1,3 +0,0 @@ -(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47) => (3,1) (10,17) -(8,10) (8,12) => (8,8) (8,14) => (8,5) (10,17) => (7,14) (10,17) => (7,1) (10,17) => (3,1) (10,17) -(1,8) (1,8) \ No newline at end of file diff --git a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs b/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs deleted file mode 100644 index eb7a8d77d3..0000000000 --- a/plugins/hls-selection-range-plugin/test/testdata/MultiPositions.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MultiPositions where - -import Data.List (find) -import qualified Data.Foldable (foldl, foldl') - -someFunc :: Int -> String -> (Int, String) -someFunc x y = - if x >= 0 - then (42, y) - else (43, y) From a240561ee4bcf418feb33de03fd4a4e5c31be08b Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 20 Jan 2022 10:03:09 +0800 Subject: [PATCH 05/19] support ghc 9 --- cabal-ghc90.project | 18 +++++ cabal-ghc921.project | 18 +++++ ghcide/src/Development/IDE/GHC/Compat.hs | 77 ++++++++++++------- .../src/Ide/Plugin/SelectionRange.hs | 6 +- .../Plugin/SelectionRange/ASTPreProcess.hs | 37 ++++++--- 5 files changed, 114 insertions(+), 42 deletions(-) diff --git a/cabal-ghc90.project b/cabal-ghc90.project index 3d4e0e33b0..76cc5c68c7 100644 --- a/cabal-ghc90.project +++ b/cabal-ghc90.project @@ -34,6 +34,24 @@ package * ghc-options: -haddock test-show-details: direct +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-test + write-ghc-environment-files: never index-state: 2022-01-11T22:05:45Z diff --git a/cabal-ghc921.project b/cabal-ghc921.project index d141315c4b..c984d19280 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -46,6 +46,24 @@ package * ghc-options: -haddock test-show-details: direct +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a + subdir: lsp-test + write-ghc-environment-files: never index-state: 2022-01-11T22:05:45Z diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 4b52ee1868..c3253d2e4a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -32,6 +32,8 @@ module Development.IDE.GHC.Compat( nodeInfo', getNodeIds, + nodeInfoFromSource, + isAnnotationInNodeInfo, isQualifiedImport, GhcVersion(..), @@ -67,71 +69,74 @@ module Development.IDE.GHC.Compat( runPp, ) where -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName, RealSrcSpan) -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.ExactPrint -import Development.IDE.GHC.Compat.Iface -import Development.IDE.GHC.Compat.Logger -import Development.IDE.GHC.Compat.Outputable -import Development.IDE.GHC.Compat.Parser -import Development.IDE.GHC.Compat.Plugins -import Development.IDE.GHC.Compat.Units -import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Iface +import Development.IDE.GHC.Compat.Logger +import Development.IDE.GHC.Compat.Outputable +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Plugins +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Compat.Util +import GHC hiding (HasSrcSpan, + ModLocation, + RealSrcSpan, getLoc, + lookupName) #if MIN_VERSION_ghc(9,0,0) import GHC.Data.StringBuffer -import GHC.Driver.Session hiding (ExposePackage) +import GHC.Driver.Session hiding (ExposePackage) import GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0) import Data.Bifunctor -import GHC.Unit.Module.ModSummary -import GHC.Driver.Env as Env +import GHC.Driver.Env as Env import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary #else import GHC.Driver.Types #endif import GHC.Iface.Env -import GHC.Iface.Make (mkIfaceExports) -import qualified GHC.SysTools.Tasks as SysTools -import qualified GHC.Types.Avail as Avail +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.SysTools.Tasks as SysTools +import qualified GHC.Types.Avail as Avail #else -import DynFlags hiding (ExposePackage) -import HscTypes -import MkIface hiding (writeIfaceFile) import qualified Avail +import DynFlags hiding (ExposePackage) +import HscTypes +import MkIface hiding (writeIfaceFile) #if MIN_VERSION_ghc(8,8,0) -import StringBuffer (hPutStringBuffer) +import StringBuffer (hPutStringBuffer) #endif import qualified SysTools #if !MIN_VERSION_ghc(8,8,0) -import SrcLoc (RealLocated) import qualified EnumSet +import SrcLoc (RealLocated) import Foreign.ForeignPtr import System.IO #endif #endif -import Compat.HieAst (enrichHie) +import Compat.HieAst (enrichHie) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.IORef -import qualified Data.Map as Map -import Data.List (foldl') +import Data.List (foldl') +import qualified Data.Map as Map +import qualified Data.Set as Set #if MIN_VERSION_ghc(9,0,0) -import qualified Data.Set as S +import qualified Data.Set as S #endif #if !MIN_VERSION_ghc(8,10,0) -import Bag (unitBag) +import Bag (unitBag) #endif #if !MIN_VERSION_ghc(9,2,0) @@ -334,6 +339,13 @@ nodeInfo' = nodeInfo -- unhelpfulSpanFS = id #endif +nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a) +#if MIN_VERSION_ghc(9,0,0) +nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo +#else +nodeInfoFromSource = Just . nodeInfo +#endif + data GhcVersion = GHC86 | GHC88 @@ -373,3 +385,10 @@ runPp = #else const SysTools.runPp #endif + +isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool +#if MIN_VERSION_ghc(9,0,0) +isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations +#else +isAnnotationInNodeInfo p = Set.member p . nodeAnnotations +#endif diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 9efc2b87cb..8d8ecead6f 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (runReader) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) +import Data.Coerce (coerce) import Data.Foldable (find) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) @@ -27,7 +28,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat (HieAST (Node), Span, getAsts) -import Development.IDE.GHC.Compat.Util (mkFastString) +import Development.IDE.GHC.Compat.Util import Ide.Plugin.SelectionRange.ASTPreProcess (PreProcessEnv (PreProcessEnv), preProcessAST) import Ide.Types (PluginDescriptor (pluginHandlers), @@ -65,8 +66,7 @@ getSelectionRanges :: NormalizedFilePath -> [Position] -> IdeAction [SelectionRa getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do (HAR{hieAst, refMap}, positionMapping) <- useE GetHieAst file positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions - ast <- MaybeT . pure $ getAsts hieAst Map.!? (mkFastString . fromNormalizedFilePath) file - + ast <- MaybeT . pure $ getAsts hieAst Map.!? (coerce. mkFastString . fromNormalizedFilePath) file let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index 7799217d60..c20e4b948f 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,12 +16,18 @@ import qualified Data.Set as Set import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl, ValBind), HieAST (..), Identifier, IdentifierDetails (identInfo), - NodeInfo (NodeInfo, nodeAnnotations, nodeIdentifiers), + NodeInfo (NodeInfo, nodeIdentifiers), RefMap, Span, flattenAst, - mkRealSrcSpan, realSrcSpanEnd, + isAnnotationInNodeInfo, + mkRealSrcSpan, + nodeInfoFromSource, + realSrcSpanEnd, realSrcSpanStart) import Development.IDE.GHC.Compat.Util (FastString) import Prelude hiding (span) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import Development.IDE.GHC.Compat (SourcedNodeInfo (..)) +#endif newtype PreProcessEnv a = PreProcessEnv { preProcessEnvRefMap :: RefMap a @@ -42,10 +49,17 @@ mergeImports node = pure $ node { nodeChildren = children } merge xs = Just (createVirtualNode xs) nodeIsImport :: HieAST a -> Bool -nodeIsImport = pairInNodeAnnotations ("ImportDecl", "ImportDecl") +nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") + +createNodeWithEmptyInfo :: Span -> [HieAST a] -> HieAST a +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +createNodeWithEmptyInfo = Node (SourcedNodeInfo mempty) +#else +createNodeWithEmptyInfo = Node (NodeInfo mempty mempty mempty) +#endif createVirtualNode :: [HieAST a] -> HieAST a -createVirtualNode nodes = Node (NodeInfo mempty mempty mempty) span' nodes +createVirtualNode nodes = createNodeWithEmptyInfo span' nodes where span' = mkRealSrcSpan (minimum locations) (maximum locations) locations = (\s -> [realSrcSpanStart s, realSrcSpanEnd s]) . nodeSpan =<< nodes @@ -65,7 +79,7 @@ mergeSignatureWithDefinition node = do mergeNearbySigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) mergeNearbySigDef refMap (n1, n2) = do - if not (("TypeSig", "Sig") `pairInNodeAnnotations` n1 && ("FunBind", "HsBindLR") `pairInNodeAnnotations` n2) + if not (("TypeSig", "Sig") `isAnnotationInAstNode` n1 && ("FunBind", "HsBindLR") `isAnnotationInAstNode` n2) then Nothing else do typeSigId <- identifierForTypeSig n1 @@ -74,15 +88,18 @@ mergeNearbySigDef refMap (n1, n2) = do then pure $ createVirtualNode [n1, n2] else Nothing -identifierForTypeSig :: HieAST a -> Maybe Identifier +identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier identifierForTypeSig node = case mapMaybe extractIdentifier nodes of [] -> Nothing (ident:_) -> Just ident where nodes = flattenAst node - extractIdentifier = fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) - . Map.toList . nodeIdentifiers . nodeInfo + + extractIdentifier :: HieAST a -> Maybe Identifier + extractIdentifier node' = nodeInfoFromSource node' >>= + (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) + . Map.toList . nodeIdentifiers) -- | is the given occurence of an identifier is a function/variable definition in the outer span isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool @@ -96,5 +113,5 @@ isIdentADef outerSpan (span, detail) = isContextInfoDef MatchBind = True isContextInfoDef _ = False -pairInNodeAnnotations :: (FastString, FastString) -> HieAST a -> Bool -pairInNodeAnnotations p node = p `Set.member` (nodeAnnotations . nodeInfo $ node) +isAnnotationInAstNode :: (FastString, FastString) -> HieAST a -> Bool +isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . nodeInfoFromSource From 9c536ad5e8cdb735ba4256d4c84b1f9ed7ef25d5 Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 20 Jan 2022 10:48:14 +0800 Subject: [PATCH 06/19] fix it for ghc-9.0 --- ghcide/src/Development/IDE/GHC/Compat.hs | 10 +++++++++- .../src/Ide/Plugin/SelectionRange/ASTPreProcess.hs | 11 ++--------- stack-9.0.2.yaml | 1 + 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index c3253d2e4a..adf34c21eb 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -34,6 +34,7 @@ module Development.IDE.GHC.Compat( getNodeIds, nodeInfoFromSource, isAnnotationInNodeInfo, + mkAstNode, isQualifiedImport, GhcVersion(..), @@ -387,8 +388,15 @@ runPp = #endif isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations #else isAnnotationInNodeInfo p = Set.member p . nodeAnnotations #endif + +mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a +#if MIN_VERSION_ghc(9,0,0) +mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) +#else +mkAstNode = Node +#endif diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index c20e4b948f..7bf8b153b9 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -19,7 +19,7 @@ import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl NodeInfo (NodeInfo, nodeIdentifiers), RefMap, Span, flattenAst, isAnnotationInNodeInfo, - mkRealSrcSpan, + mkAstNode, mkRealSrcSpan, nodeInfoFromSource, realSrcSpanEnd, realSrcSpanStart) @@ -51,15 +51,8 @@ mergeImports node = pure $ node { nodeChildren = children } nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") -createNodeWithEmptyInfo :: Span -> [HieAST a] -> HieAST a -#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) -createNodeWithEmptyInfo = Node (SourcedNodeInfo mempty) -#else -createNodeWithEmptyInfo = Node (NodeInfo mempty mempty mempty) -#endif - createVirtualNode :: [HieAST a] -> HieAST a -createVirtualNode nodes = createNodeWithEmptyInfo span' nodes +createVirtualNode nodes = mkAstNode (NodeInfo mempty mempty mempty) span' nodes where span' = mkRealSrcSpan (minimum locations) (maximum locations) locations = (\s -> [realSrcSpanStart s, realSrcSpanEnd s]) . nodeSpan =<< nodes diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml index 8a6fc004b3..f4b5ba1731 100644 --- a/stack-9.0.2.yaml +++ b/stack-9.0.2.yaml @@ -28,6 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin +- ./plugins/hls-selection-range-plugin extra-deps: - aeson-2.0.3.0 From dfe02aeae3ec3517a50d20593cdf951292f95335 Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 20 Jan 2022 16:22:34 +0800 Subject: [PATCH 07/19] remove unnecessary import --- .../src/Ide/Plugin/SelectionRange/ASTPreProcess.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index 7bf8b153b9..1c334fc68a 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -25,9 +25,6 @@ import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl realSrcSpanStart) import Development.IDE.GHC.Compat.Util (FastString) import Prelude hiding (span) -#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) -import Development.IDE.GHC.Compat (SourcedNodeInfo (..)) -#endif newtype PreProcessEnv a = PreProcessEnv { preProcessEnvRefMap :: RefMap a From 836f6802012dabf4cfb7345a356afaf3373643fb Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 20 Jan 2022 16:49:33 +0800 Subject: [PATCH 08/19] reformat GhcIde.hs --- ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index ab227029c6..c854330d9c 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,15 +9,15 @@ module Development.IDE.Plugin.HLS.GhcIde import Control.Monad.IO.Class import Development.IDE import Development.IDE.LSP.HoverDefinition -import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline -import qualified Development.IDE.Plugin.CodeAction as CodeAction -import qualified Development.IDE.Plugin.Completions as Completions -import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import qualified Development.IDE.Plugin.CodeAction as CodeAction +import qualified Development.IDE.Plugin.Completions as Completions +import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types -import Language.LSP.Server (LspM) +import Language.LSP.Server (LspM) import Language.LSP.Types -import Text.Regex.TDFA.Text () +import Text.Regex.TDFA.Text () descriptors :: [PluginDescriptor IdeState] descriptors = From 0894399929efdf275618adf7270a51db4adafe94 Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 21 Jan 2022 11:21:40 +0800 Subject: [PATCH 09/19] selection range: make it easier to understand --- ghcide/src/Development/IDE/GHC/Compat.hs | 10 ++ .../src/Ide/Plugin/SelectionRange.hs | 29 +++--- .../Plugin/SelectionRange/ASTPreProcess.hs | 97 ++++++++++++++----- 3 files changed, 101 insertions(+), 35 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index adf34c21eb..3d2bb7c0b3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -35,6 +35,7 @@ module Development.IDE.GHC.Compat( nodeInfoFromSource, isAnnotationInNodeInfo, mkAstNode, + combineRealSrcSpans', isQualifiedImport, GhcVersion(..), @@ -400,3 +401,12 @@ mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) #else mkAstNode = Node #endif + +combineRealSrcSpans' :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +#if MIN_VERSION_ghc(9,2,0) +combineRealSrcSpans' = combineRealSrcSpans +#else +combineRealSrcSpans' s1 s2 = mkRealSrcSpan + (min (realSrcSpanStart s1) (realSrcSpanEnd s2)) + (max (realSrcSpanStart s1) (realSrcSpanEnd s2)) +#endif diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 8d8ecead6f..e45b5a6f4f 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -9,6 +9,7 @@ import Control.Monad.Reader (runReader) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Data.Coerce (coerce) +import Data.Containers.ListUtils (nubOrd) import Data.Foldable (find) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) @@ -54,6 +55,7 @@ descriptor plId = (defaultPluginDescriptor plId) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do let (TextDocumentIdentifier uri) = _textDocument + -- TODO improve error reporting (both here and in 'getSelectionRanges') let filePathMaybe = toNormalizedFilePath' <$> uriToFilePath' uri case filePathMaybe of Nothing -> pure . Right . List $ [] @@ -65,13 +67,17 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do getSelectionRanges :: NormalizedFilePath -> [Position] -> IdeAction [SelectionRange] getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do (HAR{hieAst, refMap}, positionMapping) <- useE GetHieAst file + -- 'positionMapping' should be applied to the input positions before using them positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions + ast <- MaybeT . pure $ getAsts hieAst Map.!? (coerce. mkFastString . fromNormalizedFilePath) file let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) - MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ - findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' + let selectionRanges = findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' + + -- 'positionMapping' should be applied to the output ranges before returning them + MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ selectionRanges --- | Like 'toCurrentPosition', but works on 'SelectionRange' +-- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange toCurrentSelectionRange positionMapping SelectionRange{..} = do newRange <- toCurrentRange positionMapping _range @@ -82,8 +88,9 @@ toCurrentSelectionRange positionMapping SelectionRange{..} = do -- | Build all paths from ast leaf to root astPathsLeafToRoot :: HieAST a -> [SelectionRange] -astPathsLeafToRoot = mapMaybe (spansToSelectionRange . simplifySpans) . go [[]] +astPathsLeafToRoot = mapMaybe (spansToSelectionRange . nubOrd) . go [[]] where + go :: [[Span]] -> HieAST a -> [[Span]] go acc (Node _ span []) = fmap (span:) acc go acc (Node _ span children) = concatMap (go (fmap (span:) acc)) children @@ -92,16 +99,16 @@ spansToSelectionRange [] = Nothing spansToSelectionRange (span:spans) = Just $ SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} -simplifySpans :: [Span] -> [Span] -simplifySpans = foldr go [] - where - go x [] = [x] - go x (y:ys) = if x == y then y:ys else x:y:ys - -findSelectionRangesByPositions :: [SelectionRange] -> [Position] -> [SelectionRange] +-- | Filters the selection ranges containing at least one of the given positions. +findSelectionRangesByPositions :: [SelectionRange] -- ^ all possible selection ranges + -> [Position] -- ^ requested positions + -> [SelectionRange] findSelectionRangesByPositions selectionRanges = fmap findByPosition where + findByPosition :: Position -> SelectionRange findByPosition p = fromMaybe SelectionRange{_range = Range p p, _parent = Nothing} $ find (isPositionInSelectionRange p) selectionRanges + + isPositionInSelectionRange :: Position -> SelectionRange -> Bool isPositionInSelectionRange p SelectionRange{_range} = let Range sp ep = _range in sp <= p && p <= ep diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index 1c334fc68a..c18efdedba 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,7 +8,7 @@ module Ide.Plugin.SelectionRange.ASTPreProcess import Control.Monad.Reader (Reader, asks) import Data.Foldable (find, foldl') -import Data.List (groupBy) +import Data.List (foldl1', groupBy) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import qualified Data.Set as Set @@ -17,69 +16,116 @@ import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl HieAST (..), Identifier, IdentifierDetails (identInfo), NodeInfo (NodeInfo, nodeIdentifiers), - RefMap, Span, flattenAst, + RealSrcSpan, RefMap, Span, + combineRealSrcSpans', + flattenAst, isAnnotationInNodeInfo, - mkAstNode, mkRealSrcSpan, - nodeInfoFromSource, + mkAstNode, nodeInfoFromSource, realSrcSpanEnd, realSrcSpanStart) import Development.IDE.GHC.Compat.Util (FastString) import Prelude hiding (span) +{-| +Extra arguments for 'preaProcessAST', meant to be used in a 'Reader' context. We use 'Reader' to combine +-} newtype PreProcessEnv a = PreProcessEnv { preProcessEnvRefMap :: RefMap a } --- | Make the AST more suitable for generating selection range. +{-| +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 -mergeImports :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) +{-| +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 xs = Just (createVirtualNode xs) + merge xs = createVirtualNode xs nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") -createVirtualNode :: [HieAST a] -> HieAST a -createVirtualNode nodes = mkAstNode (NodeInfo mempty mempty mempty) span' nodes +createVirtualNode :: [HieAST a] -> Maybe (HieAST a) +createVirtualNode [] = Nothing +createVirtualNode children = Just $ mkAstNode (NodeInfo mempty mempty mempty) span' children where - span' = mkRealSrcSpan (minimum locations) (maximum locations) - locations = (\s -> [realSrcSpanStart s, realSrcSpanEnd s]) . nodeSpan =<< nodes + span' :: RealSrcSpan + span' = foldl1' combineRealSrcSpans' . fmap nodeSpan $ children +{-| +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 mergeNearbySigDef refMap (prev, node') of + case mergeAdjacentSigDef refMap (prev, node') of Nothing -> node':prev:others Just comb -> comb:others -mergeNearbySigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) -mergeNearbySigDef refMap (n1, n2) = do - if not (("TypeSig", "Sig") `isAnnotationInAstNode` n1 && ("FunBind", "HsBindLR") `isAnnotationInAstNode` n2) - then Nothing - else do - typeSigId <- identifierForTypeSig n1 - refs <- Map.lookup typeSigId refMap - if any (isIdentADef (nodeSpan n2)) refs - then pure $ createVirtualNode [n1, n2] - else Nothing +-- | 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 createVirtualNode [n1, 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 @@ -91,14 +137,17 @@ identifierForTypeSig node = (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) . Map.toList . nodeIdentifiers) --- | is the given occurence of an identifier is a function/variable definition in the outer span +-- | Determines if the given occurence 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 . Set.toList . identInfo $ detail + -- does the 'ContextInfo' represents a variable/function definition? + isContextInfoDef :: ContextInfo -> Bool isContextInfoDef ValBind{} = True isContextInfoDef MatchBind = True isContextInfoDef _ = False From 1a7d0f5f121dea89bc07d9daff6280e9290cfdef Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 21 Jan 2022 16:19:07 +0800 Subject: [PATCH 10/19] selection range: improve error handling --- ghcide/src/Development/IDE/GHC/Compat.hs | 18 ++++-- .../src/Ide/Plugin/SelectionRange.hs | 58 +++++++++++++------ .../Plugin/SelectionRange/ASTPreProcess.hs | 10 ++-- 3 files changed, 57 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 3d2bb7c0b3..76c5c055dd 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -35,7 +35,7 @@ module Development.IDE.GHC.Compat( nodeInfoFromSource, isAnnotationInNodeInfo, mkAstNode, - combineRealSrcSpans', + combineRealSrcSpans, isQualifiedImport, GhcVersion(..), @@ -89,6 +89,7 @@ import GHC hiding (HasSrcSpan, #if MIN_VERSION_ghc(9,0,0) import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0) import Data.Bifunctor @@ -402,11 +403,16 @@ mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) mkAstNode = Node #endif -combineRealSrcSpans' :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan #if MIN_VERSION_ghc(9,2,0) -combineRealSrcSpans' = combineRealSrcSpans +combineRealSrcSpans = SrcLoc.combineRealSrcSpans #else -combineRealSrcSpans' s1 s2 = mkRealSrcSpan - (min (realSrcSpanStart s1) (realSrcSpanEnd s2)) - (max (realSrcSpanStart s1) (realSrcSpanEnd s2)) +combineRealSrcSpans span1 span2 + = mkRealSrcSpan (mkRealSrcLoc file line_start col_start) (mkRealSrcLoc file line_end col_end) + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 #endif diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index e45b5a6f4f..528e9bb2b5 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -4,21 +4,26 @@ module Ide.Plugin.SelectionRange (descriptor) where +import Control.Monad.Except (ExceptT (ExceptT), + runExceptT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (runReader) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), - runMaybeT) + maybeToExceptT) import Data.Coerce (coerce) import Data.Containers.ListUtils (nubOrd) +import Data.Either.Extra (maybeToEither) import Data.Foldable (find) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T import Development.IDE (GetHieAst (GetHieAst), HieAstResult (HAR, hieAst, refMap), IdeAction, IdeState (shakeExtras), Range (Range), fromNormalizedFilePath, + ideLogger, logInfo, realSrcSpanToRange, runIdeAction, toNormalizedFilePath', @@ -32,6 +37,7 @@ import Development.IDE.GHC.Compat (HieAST (Node), Span, import Development.IDE.GHC.Compat.Util import Ide.Plugin.SelectionRange.ASTPreProcess (PreProcessEnv (PreProcessEnv), preProcessAST) +import Ide.PluginUtils (response) import Ide.Types (PluginDescriptor (pluginHandlers), PluginId, defaultPluginDescriptor, @@ -44,7 +50,8 @@ import Language.LSP.Types (List (List), SMethod (STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), - TextDocumentIdentifier (TextDocumentIdentifier)) + TextDocumentIdentifier (TextDocumentIdentifier), + Uri) import Prelude hiding (span) descriptor :: PluginId -> PluginDescriptor IdeState @@ -54,28 +61,40 @@ descriptor plId = (defaultPluginDescriptor plId) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do - let (TextDocumentIdentifier uri) = _textDocument - -- TODO improve error reporting (both here and in 'getSelectionRanges') - let filePathMaybe = toNormalizedFilePath' <$> uriToFilePath' uri - case filePathMaybe of - Nothing -> pure . Right . List $ [] - Just filePath -> liftIO $ do - let (List positions) = _positions - selectionRanges <- runIdeAction "SelectionRange" (shakeExtras ide) $ getSelectionRanges filePath positions - pure . Right . List $ selectionRanges + liftIO $ logInfo logger $ "requesting selection range for file: " <> T.pack (show uri) + response $ do + filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $ + getSelectionRanges filePath positions + pure . List $ selectionRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + + positions :: [Position] + List positions = _positions -getSelectionRanges :: NormalizedFilePath -> [Position] -> IdeAction [SelectionRange] -getSelectionRanges file positions = fmap (fromMaybe []) <$> runMaybeT $ do - (HAR{hieAst, refMap}, positionMapping) <- useE GetHieAst file + logger = ideLogger ide + +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] +getSelectionRanges file positions = do + (HAR{hieAst, refMap}, positionMapping) <- maybeToExceptT "fail to get hie ast" $ useE GetHieAst file -- 'positionMapping' should be applied to the input positions before using them - positions' <- MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions + positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $ + traverse (fromCurrentPosition positionMapping) positions + + ast <- maybeToExceptT "fail to get ast for current file" . MaybeT . pure $ + -- in GHC 9, the 'FastString' in 'HieASTs' is replaced by a newtype wrapper around 'LexicalFastString' + -- so we use 'coerce' to make it work in both GHC 8 and 9 + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file - ast <- MaybeT . pure $ getAsts hieAst Map.!? (coerce. mkFastString . fromNormalizedFilePath) file let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) let selectionRanges = findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' -- 'positionMapping' should be applied to the output ranges before returning them - MaybeT . pure . traverse (toCurrentSelectionRange positionMapping) $ selectionRanges + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange @@ -99,7 +118,10 @@ spansToSelectionRange [] = Nothing spansToSelectionRange (span:spans) = Just $ SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} --- | Filters the selection ranges containing at least one of the given positions. +{-| +Filters the selection ranges containing at least one of the given positions, without taking each selection range's +parent into account. +-} findSelectionRangesByPositions :: [SelectionRange] -- ^ all possible selection ranges -> [Position] -- ^ requested positions -> [SelectionRange] diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index c18efdedba..48b3d16251 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -17,7 +17,7 @@ import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl IdentifierDetails (identInfo), NodeInfo (NodeInfo, nodeIdentifiers), RealSrcSpan, RefMap, Span, - combineRealSrcSpans', + combineRealSrcSpans, flattenAst, isAnnotationInNodeInfo, mkAstNode, nodeInfoFromSource, @@ -73,7 +73,7 @@ createVirtualNode [] = Nothing createVirtualNode children = Just $ mkAstNode (NodeInfo mempty mempty mempty) span' children where span' :: RealSrcSpan - span' = foldl1' combineRealSrcSpans' . fmap nodeSpan $ children + span' = foldl1' combineRealSrcSpans . fmap nodeSpan $ children {-| Combine type signature with variable definition under a new parent node, if the signature is placed right before the @@ -82,11 +82,11 @@ definition. This allows the user to have a step selecting both type signature an 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. + -- 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 + -- 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' = @@ -146,7 +146,7 @@ isIdentADef outerSpan (span, detail) = isDef :: Bool isDef = any isContextInfoDef . Set.toList . identInfo $ detail - -- does the 'ContextInfo' represents a variable/function definition? + -- Does the 'ContextInfo' represents a variable/function definition? isContextInfoDef :: ContextInfo -> Bool isContextInfoDef ValBind{} = True isContextInfoDef MatchBind = True From 83f620116ced33c796762e88589993c7d8c44b5f Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 21 Jan 2022 21:32:29 +0800 Subject: [PATCH 11/19] update lsp-types to 1.4.0.1 --- cabal-ghc90.project | 20 +------------------- cabal-ghc921.project | 20 +------------------- cabal.project | 20 +------------------- ghcide/ghcide.cabal | 2 +- hls-test-utils/hls-test-utils.cabal | 2 +- stack-8.10.6.yaml | 9 +++------ stack-8.10.7.yaml | 9 +++------ stack-8.6.5.yaml | 9 +++------ stack-8.8.4.yaml | 9 +++------ stack-9.0.1.yaml | 9 +++------ stack-9.0.2.yaml | 3 +++ stack.yaml | 9 +++------ 12 files changed, 26 insertions(+), 95 deletions(-) diff --git a/cabal-ghc90.project b/cabal-ghc90.project index c6b3b25aa6..6e9ff499bb 100644 --- a/cabal-ghc90.project +++ b/cabal-ghc90.project @@ -34,27 +34,9 @@ package * ghc-options: -haddock test-show-details: direct -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-types - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-test - write-ghc-environment-files: never -index-state: 2022-01-11T22:05:45Z +index-state: 2022-01-21T11:23:29Z constraints: -- These plugins don't work on GHC9 yet diff --git a/cabal-ghc921.project b/cabal-ghc921.project index c984d19280..aee611b5c2 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -46,27 +46,9 @@ package * ghc-options: -haddock test-show-details: direct -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-types - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-test - write-ghc-environment-files: never -index-state: 2022-01-11T22:05:45Z +index-state: 2022-01-21T11:23:29Z constraints: -- These plugins don't build/work on GHC92 yet diff --git a/cabal.project b/cabal.project index e2e2ab121f..96fb8153f0 100644 --- a/cabal.project +++ b/cabal.project @@ -39,27 +39,9 @@ package * ghc-options: -haddock test-show-details: direct -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-types - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp - -source-repository-package - type: git - location: https://github.com/haskell/lsp.git - tag: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdir: lsp-test - write-ghc-environment-files: never -index-state: 2022-01-11T22:05:45Z +index-state: 2022-01-21T11:23:29Z constraints: hyphenation +embed diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 57976ef2d4..d20d2408aa 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -64,7 +64,7 @@ library lens, list-t, hiedb == 0.4.1.*, - lsp-types ^>= 1.4.0.0, + lsp-types ^>= 1.4.0.1, lsp ^>= 1.4.0.0 , monoid-subclasses, mtl, diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 5eb4c7cfaa..a6f5dec9d3 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -49,7 +49,7 @@ library , lens , lsp ^>=1.4 , lsp-test ^>=0.14 - , lsp-types ^>=1.4 + , lsp-types ^>=1.4.0.1 , tasty , tasty-expected-failure , tasty-golden diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index 09bd4641f0..321f143bcd 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -47,12 +47,9 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test + - lsp-1.4.0.0 + - lsp-types-1.4.0.1 + - lsp-test-0.14.0.2 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 5f714ffe3b..f373a37ea5 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -48,12 +48,9 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test + - lsp-1.4.0.0 + - lsp-types-1.4.0.1 + - lsp-test-0.14.0.2 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index c03c7d0162..121998bfc6 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -105,12 +105,9 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 - - git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test + - lsp-1.4.0.0 + - lsp-types-1.4.0.1 + - lsp-test-0.14.0.2 - mod-0.1.2.2 - semirings-0.6 - stm-containers-1.1.0.4 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 957067eedd..ce00d47573 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -81,12 +81,9 @@ extra-deps: - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test + - lsp-1.4.0.0 + - lsp-types-1.4.0.1 + - lsp-test-0.14.0.2 - stm-containers-1.1.0.4 - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 - primitive-extras-0.10.1 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 87791e9dc7..2f75afbaee 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -50,12 +50,9 @@ extra-deps: - monad-dijkstra-0.1.1.3 - multistate-0.8.0.3 - retrie-1.1.0.0 -- git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test +- lsp-1.4.0.0 +- lsp-types-1.4.0.1 +- lsp-test-0.14.0.2 - refinery-0.4.0.0 # shake-bench dependencies diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml index f4b5ba1731..8983f55357 100644 --- a/stack-9.0.2.yaml +++ b/stack-9.0.2.yaml @@ -50,6 +50,9 @@ extra-deps: - monad-dijkstra-0.1.1.3 - multistate-0.8.0.3 - retrie-1.1.0.0 +- lsp-1.4.0.0 +- lsp-types-1.4.0.1 +- lsp-test-0.14.0.2 - unix-compat-0.5.4 # shake-bench dependencies diff --git a/stack.yaml b/stack.yaml index 5f714ffe3b..f373a37ea5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,12 +48,9 @@ extra-deps: - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - - git: https://github.com/haskell/lsp.git - commit: bad3d45854e5ca4eaf53985e9cee42d25840d18a - subdirs: - - lsp - - lsp-types - - lsp-test + - lsp-1.4.0.0 + - lsp-types-1.4.0.1 + - lsp-test-0.14.0.2 - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 From 48a47091d5595bc7e7769c603cd15ec3c15b6ecd Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 22 Jan 2022 16:39:54 +0800 Subject: [PATCH 12/19] add selection range to doc --- docs/features.md | 11 +++++++++-- docs/supported-versions.md | 1 + 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/docs/features.md b/docs/features.md index ad72367ed0..78d8ccc411 100644 --- a/docs/features.md +++ b/docs/features.md @@ -18,6 +18,7 @@ Many of these are standard LSP features, but a lot of special features are provi | [Highlight references](#highlight-references) | `textDocument/documentHighlight` | | [Code actions](#code-actions) | `textDocument/codeAction` | | [Code lenses](#code-lenses) | `textDocument/codeLens` | +| [Selection range](#selection-range) | `textDocument/selectionRange` | The individual sections below also identify which [HLS plugin](./what-is-hls.md#hls-plugins) is responsible for providing the given functionality, which is useful if you want to raise an issue report or contribute! Additionally, not all plugins are supported on all versions of GHC, see the [GHC version support page](supported-versions.md) for details. @@ -141,7 +142,7 @@ Code action kind: `quickfix` Rewrites imported names to be qualified. ![Qualify Imported Names Demo](../plugins/hls-qualify-imported-names-plugin/qualify-imported-names-demo.gif) - + For usage see the ![readme](../plugins/hls-qualify-imported-names-plugin/README.md). ### Refine import @@ -239,6 +240,13 @@ Shows module name matching file path, and applies it with a click. ![Module Name Demo](https://user-images.githubusercontent.com/54035/110860755-78ad8680-82bd-11eb-9845-9ea4b1cc1f76.gif) +## Selection range +Provided by: `hls-selection-range-plugin` + +Provides haskell specific +[shrink/expand selection](https://code.visualstudio.com/docs/editor/codebasics#shrinkexpand-selection) +support. + ## Missing features The following features are supported by the LSP specification but not implemented in HLS. @@ -251,7 +259,6 @@ Contributions welcome! | Jump to implementation | Unclear if useful | `textDocument/implementation` | | Renaming | [Parital implementation](https://github.com/haskell/haskell-language-server/issues/2193) | `textDocument/rename`, `textDocument/prepareRename` | | Folding | Unimplemented | `textDocument/foldingRange` | -| Selection range | Unimplemented | `textDocument/selectionRange` | | Semantic tokens | Unimplemented | `textDocument/semanticTokens` | | Linked editing | Unimplemented | `textDocument/linkedEditingRange` | | Document links | Unimplemented | `textDocument/documentLink` | diff --git a/docs/supported-versions.md b/docs/supported-versions.md index caf0f9f3ce..21afba0582 100644 --- a/docs/supported-versions.md +++ b/docs/supported-versions.md @@ -50,6 +50,7 @@ As such, the functionality provided by those plugins is not available in HLS whe | `hls-splice-plugin` | 9.2 | | `hls-stylish-haskell-plugin` | 9.0, 9.2 | | `hls-tactics-plugin` | 9.2 | +| `hls-selection-range-plugin` | | ### Using deprecated GHC versions From bd7fcfdda740374a8dba16ebd5cdad8853403381 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 22 Jan 2022 22:28:08 +0800 Subject: [PATCH 13/19] fix comment for findSelectionRangesByPositions --- .../src/Ide/Plugin/SelectionRange.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 528e9bb2b5..82c3b7ac34 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -119,13 +119,21 @@ spansToSelectionRange (span:spans) = Just $ SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} {-| -Filters the selection ranges containing at least one of the given positions, without taking each selection range's -parent into account. +For each position, find the selection range that contains it, without taking each selection range's +parent into account. These selection ranges are un-divisible, representing the leaf nodes in original AST, so they +won't overlap. -} findSelectionRangesByPositions :: [SelectionRange] -- ^ all possible selection ranges -> [Position] -- ^ requested positions -> [SelectionRange] findSelectionRangesByPositions selectionRanges = fmap findByPosition + {- + Performance Tips: + Doing a linear search from the first selection range for each position is not optimal. + If it becomes too slow for a large file and many positions, you may optimize the implementation. + At least we don't need to search from the very beginning for each position, if the are sorted firstly. + Or maybe we could apply some techniques like binary search? + -} where findByPosition :: Position -> SelectionRange findByPosition p = fromMaybe SelectionRange{_range = Range p p, _parent = Nothing} $ From a7ce3869e03430f5cc711110c373cd1047b3cd2c Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 22 Jan 2022 23:47:15 +0800 Subject: [PATCH 14/19] remove a use of partial function --- .../Plugin/SelectionRange/ASTPreProcess.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index 48b3d16251..f3661be8d0 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -7,8 +7,10 @@ module Ide.Plugin.SelectionRange.ASTPreProcess ) where import Control.Monad.Reader (Reader, asks) -import Data.Foldable (find, foldl') -import Data.List (foldl1', groupBy) +import Data.Foldable (find, foldl', foldl1) +import Data.List (groupBy) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import qualified Data.Set as Set @@ -61,19 +63,18 @@ mergeImports node = pure $ node { nodeChildren = children } . nodeChildren $ node merge :: [HieAST a] -> Maybe (HieAST a) - merge [] = Nothing - merge [x] = Just x - merge xs = createVirtualNode xs + merge [] = Nothing + merge [x] = Just x + merge (x:xs) = Just $ createVirtualNode (x NonEmpty.:| xs) nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") -createVirtualNode :: [HieAST a] -> Maybe (HieAST a) -createVirtualNode [] = Nothing -createVirtualNode children = Just $ mkAstNode (NodeInfo mempty mempty mempty) span' children +createVirtualNode :: NonEmpty (HieAST a) -> HieAST a +createVirtualNode children = mkAstNode (NodeInfo mempty mempty mempty) span' (NonEmpty.toList children) where span' :: RealSrcSpan - span' = foldl1' combineRealSrcSpans . fmap nodeSpan $ children + span' = foldl1 combineRealSrcSpans . fmap nodeSpan $ children {-| Combine type signature with variable definition under a new parent node, if the signature is placed right before the @@ -107,7 +108,7 @@ mergeAdjacentSigDef refMap (n1, n2) = do -- 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 createVirtualNode [n1, n2] + then pure . createVirtualNode $ n1 NonEmpty.:| [n2] else Nothing where checkAnnotation :: Maybe () From 23ea08e17965230afdf3fe97b68b4243633189b7 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 22 Jan 2022 23:49:48 +0800 Subject: [PATCH 15/19] update author & maintainer --- .../hls-selection-range-plugin.cabal | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal index dad0d012e3..b8c02989b5 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -9,11 +9,8 @@ description: license: Apache-2.0 license-file: LICENSE -author: - https://github.com/haskell/haskell-language-server/contributors - -maintainer: - https://github.com/haskell/haskell-language-server/contributors +author: kokobd +maintainer: kokobd category: Development build-type: Simple From cd5d8bc88e0136fbf38a5f9df2e1e57f74202a9a Mon Sep 17 00:00:00 2001 From: kokobd Date: Sun, 23 Jan 2022 08:37:36 +0800 Subject: [PATCH 16/19] use foldlM1 instead of foldl1 --- .../hls-selection-range-plugin.cabal | 1 + .../src/Ide/Plugin/SelectionRange/ASTPreProcess.hs | 6 ++++-- plugins/hls-selection-range-plugin/test/testdata/hie.yaml | 3 ++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal index b8c02989b5..f7b331d8bd 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -36,6 +36,7 @@ library , mtl , text , extra + , semigroupoids test-suite tests type: exitcode-stdio-1.0 diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs index f3661be8d0..9fd6ab24c2 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs @@ -7,12 +7,14 @@ module Ide.Plugin.SelectionRange.ASTPreProcess ) where import Control.Monad.Reader (Reader, asks) -import Data.Foldable (find, foldl', foldl1) +import Data.Foldable (find, foldl') +import Data.Functor.Identity (Identity (Identity, runIdentity)) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) +import Data.Semigroup.Foldable (foldlM1) import qualified Data.Set as Set import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl, ValBind), HieAST (..), Identifier, @@ -74,7 +76,7 @@ createVirtualNode :: NonEmpty (HieAST a) -> HieAST a createVirtualNode children = mkAstNode (NodeInfo mempty mempty mempty) span' (NonEmpty.toList children) where span' :: RealSrcSpan - span' = foldl1 combineRealSrcSpans . fmap nodeSpan $ children + span' = runIdentity . foldlM1 (\x y -> Identity (combineRealSrcSpans x y)) . fmap nodeSpan $ children {-| Combine type signature with variable definition under a new parent node, if the signature is placed right before the diff --git a/plugins/hls-selection-range-plugin/test/testdata/hie.yaml b/plugins/hls-selection-range-plugin/test/testdata/hie.yaml index e2799dc09a..bf7a576fe2 100644 --- a/plugins/hls-selection-range-plugin/test/testdata/hie.yaml +++ b/plugins/hls-selection-range-plugin/test/testdata/hie.yaml @@ -1,4 +1,5 @@ cradle: direct: arguments: - - "A" + - "Import" + - "Function" From 8e975df4377ab652c3d48499afd0b240f60808c7 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sun, 23 Jan 2022 18:26:00 +0800 Subject: [PATCH 17/19] add testdata to cabal file --- .../hls-selection-range-plugin.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal index f7b331d8bd..f7f557e758 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal @@ -16,6 +16,9 @@ category: Development build-type: Simple extra-source-files: LICENSE + test/testdata/*.hs + test/testdata/*.yaml + test/testdata/*.txt library exposed-modules: From 94d45b603d0f7524fafe19290e0003459a4ecf7f Mon Sep 17 00:00:00 2001 From: kokobd Date: Sun, 23 Jan 2022 20:37:49 +0800 Subject: [PATCH 18/19] update performace tips and log level --- .../src/Ide/Plugin/SelectionRange.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs index 82c3b7ac34..3e25e41b55 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs @@ -23,7 +23,7 @@ import Development.IDE (GetHieAst (GetHieAst), IdeState (shakeExtras), Range (Range), fromNormalizedFilePath, - ideLogger, logInfo, + ideLogger, logDebug, realSrcSpanToRange, runIdeAction, toNormalizedFilePath', @@ -61,7 +61,7 @@ descriptor plId = (defaultPluginDescriptor plId) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do - liftIO $ logInfo logger $ "requesting selection range for file: " <> T.pack (show uri) + liftIO $ logDebug logger $ "requesting selection range for file: " <> T.pack (show uri) response $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ toNormalizedFilePath' <$> uriToFilePath' uri @@ -131,8 +131,9 @@ findSelectionRangesByPositions selectionRanges = fmap findByPosition Performance Tips: Doing a linear search from the first selection range for each position is not optimal. If it becomes too slow for a large file and many positions, you may optimize the implementation. - At least we don't need to search from the very beginning for each position, if the are sorted firstly. - Or maybe we could apply some techniques like binary search? + Assume the number of selection range is n, then the following techniques may be applied: + 1. For each position, we may treat HieAST as a position indexed tree to search it in O(log(n)). + 2. For all positions, a searched position will narrow the search range for other positions. -} where findByPosition :: Position -> SelectionRange From 72112bce65fe4c7be4b2519981697c992af64b81 Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 24 Jan 2022 20:09:17 +0800 Subject: [PATCH 19/19] update lsp-types in nix --- flake.lock | 8 ++++---- flake_hackage/flake.nix | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/flake.lock b/flake.lock index dc7b690ee8..ade3851966 100644 --- a/flake.lock +++ b/flake.lock @@ -110,7 +110,7 @@ "retrie": "retrie" }, "locked": { - "narHash": "sha256-gVzFEW0y/uPHJaGJ6w7VZc3QDhH6latvmYHJuzaXDa0=", + "narHash": "sha256-/F3itZJSZDnaxRGpkTffHDkxC7PloYqxVTW//bP3i20=", "path": "./flake_hackage", "type": "path" }, @@ -158,13 +158,13 @@ "lsp-types": { "flake": false, "locked": { - "narHash": "sha256-K1CeV6o5mmrXubATCh19iFatJ1RtPwpY5lxD8rf/SIw=", + "narHash": "sha256-HGg4upgirM6/px+vflY5S0Y79gAIDpl32Ad9mbbzTdU=", "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-types-1.4.0.0/lsp-types-1.4.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-types-1.4.0.1/lsp-types-1.4.0.1.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-types-1.4.0.0/lsp-types-1.4.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-types-1.4.0.1/lsp-types-1.4.0.1.tar.gz" } }, "nixpkgs": { diff --git a/flake_hackage/flake.nix b/flake_hackage/flake.nix index 3b91d2e04f..212cf1e7f7 100644 --- a/flake_hackage/flake.nix +++ b/flake_hackage/flake.nix @@ -7,7 +7,7 @@ flake = false; }; lsp-types = { - url = "https://hackage.haskell.org/package/lsp-types-1.4.0.0/lsp-types-1.4.0.0.tar.gz"; + url = "https://hackage.haskell.org/package/lsp-types-1.4.0.1/lsp-types-1.4.0.1.tar.gz"; flake = false; }; lsp-test = {