From b7da1f5700a28032bc1ecc2fc194e3951ac08d5c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 16 May 2024 19:34:48 +0800 Subject: [PATCH 01/51] Provide explicit import in inlay hints --- hls-plugin-api/src/Ide/Types.hs | 12 +++++ .../src/Ide/Plugin/ExplicitImports.hs | 53 +++++++++++++++---- 2 files changed, 54 insertions(+), 11 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 5212b2c6da..3699e13d89 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -504,6 +504,12 @@ instance PluginMethod Request Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be? handlesRequest _ _ _ _ = HandlesRequest +instance PluginMethod Request Method_TextDocumentInlayHint where + handlesRequest _ _ _ _ = HandlesRequest + +instance PluginMethod Request Method_InlayHintResolve where + handlesRequest _ _ _ _ = HandlesRequest + instance PluginMethod Request Method_TextDocumentCodeLens where handlesRequest = pluginEnabledWithFeature plcCodeLensOn @@ -803,6 +809,12 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentInlayHint where + combineResponses _ _ _ _ (x :| _) = x + +instance PluginRequestMethod Method_InlayHintResolve where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 2c599b5b6b..9eaa213655 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} + module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules @@ -22,6 +23,7 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) +import Data.Char (isSpace) import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) import Data.IORef (readIORef) @@ -44,8 +46,9 @@ import GHC.Generics (Generic) import Ide.Plugin.Error (PluginError (..), getNormalizedFilePathE, handleMaybe) -import Ide.Plugin.RangeMap (filterByRange) -import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, + filterByRange, + fromList) import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types @@ -98,9 +101,11 @@ descriptorForModules recorder modFilter plId = -- This plugin provides code lenses mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) - -- This plugin provides code actions + -- This plugin provides inlay hints + <> mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder) + -- <> mkResolveHandler SMethod_InlayHintResolve (inlayHintResolveProvider recorder) + -- This plugin provides code actions <> codeActionHandlers - } -- | The actual command handler @@ -146,12 +151,13 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { , _range = range , _command = Nothing } + lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do nfp <- getNormalizedFilePathE uri (ImportActionsResult{forResolve}, _) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid - let updatedCodeLens = cl & L.command ?~ mkCommand plId target + let updatedCodeLens = cl & L.command ?~ mkCommand plId target pure updatedCodeLens where mkCommand :: PluginId -> ImportEdit -> Command mkCommand pId (ImportEdit{ieResType, ieText}) = @@ -166,6 +172,35 @@ lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do lensResolveProvider _ _ _ _ _ rd = do throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for lens resolve handler: " <> show rd) + +inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}} = do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let inlayHints = [ generateInlayHints newRange ie + | (range, int) <- forLens + , Just newRange <- [toCurrentRange pm range] + , Just ie <- [forResolve IM.!? int]] + pure $ InL inlayHints + where + generateInlayHints :: Range -> ImportEdit -> InlayHint + generateInlayHints Range {_end} ie = + InlayHint { _position = _end + , _label = mkLabel ie + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + } + mkLabel :: ImportEdit -> T.Text |? [InlayHintLabelPart] + mkLabel (ImportEdit{ieResType, ieText}) = + let title ExplicitImport = abbreviateImportTitle $ (T.intercalate " " . filter (not . T.null) . T.split isSpace . T.dropWhile (/= '(')) ieText + title RefineImport = T.intercalate ", " (T.lines ieText) + in InL $ title ieResType + + -- |For explicit imports: If there are any implicit imports, provide both one -- code action per import to make that specific import explicit, and one code -- action to turn them all into explicit imports. For refine imports: If there @@ -176,7 +211,7 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier nfp <- getNormalizedFilePathE _uri (ImportActionsResult{forCodeActions}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp newRange <- toCurrentRangeE pm range - let relevantCodeActions = filterByRange newRange forCodeActions + let relevantCodeActions = RM.filterByRange newRange forCodeActions allExplicit = [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ExplicitAll _uri) -- We should only provide this code action if there are any code @@ -410,7 +445,6 @@ isExplicitImport _ = False maxColumns :: Int maxColumns = 120 - -- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). -- So we abbreviate it to fit a max column size, and indicate how many more items are in the list @@ -462,10 +496,7 @@ filterByImport (ImportDecl{ideclHiding = Just (_, L _ names)}) else Nothing where importedNames = S.fromList $ map (ieName . unLoc) names res = flip Map.filter avails $ \a -> - any (`S.member` importedNames) - $ concatMap - getAvailNames - a + any (any (`S.member` importedNames) . getAvailNames) a allFilteredAvailsNames = S.fromList $ concatMap getAvailNames $ mconcat From 3305973b76a3892da6bba64217ff65ce3527036f Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Fri, 14 Jun 2024 20:36:26 +0800 Subject: [PATCH 02/51] Filter explict imports inlay hints by visible range --- .../src/Ide/Plugin/ExplicitImports.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 9eaa213655..ef170adef8 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -11,6 +11,7 @@ module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules , abbreviateImportTitle + , squashedAbbreviateImportTitle , Log(..) ) where @@ -174,11 +175,12 @@ lensResolveProvider _ _ _ _ _ rd = do inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint -inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}} = do +inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = do nfp <- getNormalizedFilePathE _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let inlayHints = [ generateInlayHints newRange ie | (range, int) <- forLens + , range < visibleRange , Just newRange <- [toCurrentRange pm range] , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints @@ -194,10 +196,10 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , _paddingRight = Nothing , _data_ = Nothing } - mkLabel :: ImportEdit -> T.Text |? [InlayHintLabelPart] + mkLabel :: ImportEdit -> T.Text |? [InlayHintLabelPart] mkLabel (ImportEdit{ieResType, ieText}) = - let title ExplicitImport = abbreviateImportTitle $ (T.intercalate " " . filter (not . T.null) . T.split isSpace . T.dropWhile (/= '(')) ieText - title RefineImport = T.intercalate ", " (T.lines ieText) + let title ExplicitImport = squashedAbbreviateImportTitle ieText + title RefineImport = T.intercalate ", " (T.lines ieText) in InL $ title ieResType @@ -445,7 +447,6 @@ isExplicitImport _ = False maxColumns :: Int maxColumns = 120 --- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). -- So we abbreviate it to fit a max column size, and indicate how many more items are in the list -- after the abbreviation @@ -478,6 +479,10 @@ abbreviateImportTitle input = else actualPrefix <> suffixText in title +squashedAbbreviateImportTitle :: T.Text -> T.Text +squashedAbbreviateImportTitle ieText = abbreviateImportTitle $ (T.intercalate " " . filter (not . T.null) . T.split isSpace . T.dropWhile (/= '(')) ieText + +-- | The title of the command is ideally the minimal explicit import decl, but -------------------------------------------------------------------------------- From 245049a58078d7271912a3e12aa16936e6028a11 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Fri, 14 Jun 2024 20:38:46 +0800 Subject: [PATCH 03/51] Update lsp dep by source-repository-package to writing test before new release of haskell/lsp. --- cabal.project | 18 ++++++++++++++++++ ghcide/ghcide.cabal | 2 +- haskell-language-server.cabal | 14 +++++++------- hls-plugin-api/hls-plugin-api.cabal | 2 +- 4 files changed, 27 insertions(+), 9 deletions(-) diff --git a/cabal.project b/cabal.project index d7339b4d80..2eb1371a74 100644 --- a/cabal.project +++ b/cabal.project @@ -16,6 +16,24 @@ benchmarks: True write-ghc-environment-files: never +source-repository-package + type: git + location: https://github.com/jetjinser/lsp + tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f + subdir: lsp-test + +source-repository-package + type: git + location: https://github.com/jetjinser/lsp + tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f + subdir: lsp + +source-repository-package + type: git + location: https://github.com/jetjinser/lsp + tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f + subdir: lsp-types + -- Many of our tests only work single-threaded, and the only way to -- ensure tasty runs everything purely single-threaded is to pass -- this at the top-level diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0d70f31bb7..2b5be914d4 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -88,7 +88,7 @@ library , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t - , lsp ^>=2.5.0.0 + , lsp ^>=2.6.0.0 , lsp-types ^>=2.2.0.0 , mtl , opentelemetry >=0.6.1 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5f673caafe..92bcc694ab 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -258,7 +258,7 @@ library hls-cabal-plugin , hls-plugin-api == 2.8.0.0 , hls-graph == 2.8.0.0 , lens - , lsp ^>=2.5 + , lsp ^>=2.6 , lsp-types ^>=2.2 , regex-tdfa ^>=1.3.1 , text @@ -389,7 +389,7 @@ library hls-call-hierarchy-plugin , hiedb ^>= 0.6.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , sqlite-simple , text @@ -1002,7 +1002,7 @@ library hls-alternate-number-format-plugin , hls-graph , hls-plugin-api == 2.8.0.0 , lens - , lsp ^>=2.5 + , lsp ^>=2.6 , mtl , regex-tdfa , syb @@ -1232,7 +1232,7 @@ library hls-gadt-plugin , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens - , lsp >=2.5 + , lsp >=2.6 , mtl , text , transformers @@ -1281,7 +1281,7 @@ library hls-explicit-fixity-plugin , ghcide == 2.8.0.0 , hashable , hls-plugin-api == 2.8.0.0 - , lsp >=2.5 + , lsp >=2.6 , text default-extensions: DataKinds @@ -1736,7 +1736,7 @@ library hls-semantic-tokens-plugin , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , text , transformers , bytestring @@ -1804,7 +1804,7 @@ library hls-notes-plugin , hls-graph == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , mtl >= 2.2 , regex-tdfa >= 1.3.1 , text diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 4e8bb6742c..eef8a7038c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -69,7 +69,7 @@ library , hls-graph == 2.8.0.0 , lens , lens-aeson - , lsp ^>=2.5 + , lsp ^>=2.6 , megaparsec >=9.0 , mtl , opentelemetry >=0.4 From 059813866f354fab7e4ff8d31b5857f542d81970 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Fri, 14 Jun 2024 20:40:41 +0800 Subject: [PATCH 04/51] Add test for hls-explicit-imports-plugin inlay hints --- .../hls-explicit-imports-plugin/test/Main.hs | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 0fd94a807c..6ef8731e7c 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -34,10 +34,33 @@ main = defaultTestRunner $ testGroup "import-actions" "Make imports explicit" [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0 , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0 + , inlayHintsTest "ExplicitUsualCase" 3 0 $ (@=?) + [InlayHint + { _position = Position {_line = 2, _character = 16} + , _label = InL "( a1 )" + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + }] , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0 + , inlayHintsTest "ExplicitOnlyThis" 3 0 $ (@?=) + [InlayHint + { _position = Position {_line = 2, _character = 16} + , _label = InL "( a1 )" + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + }] , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 , codeActionBreakFile "ExplicitBreakFile" 4 0 + , inlayHintsTest "ExplicitBreakFile" 3 0 $ (@=?) [] , codeActionStaleAction "ExplicitStaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer def explicitImportsPlugin testDataDir $ do @@ -49,6 +72,11 @@ main = defaultTestRunner $ testGroup "import-actions" doc <- openDoc "ExplicitExported.hs" "haskell" lenses <- getCodeLenses doc liftIO $ lenses @?= [] + , testCase "No InlayHints when exported" $ + runSessionWithServer def explicitImportsPlugin testDataDir $ do + doc <- openDoc "ExplicitExported.hs" "haskell" + inlayHints <- getInlayHints doc (pointRange 3 0) + liftIO $ inlayHints @?= [] , testGroup "Title abbreviation" [ testCase "not abbreviated" $ let i = "import " <> T.replicate 70 "F" <> " (Athing, Bthing, Cthing)" @@ -72,6 +100,20 @@ main = defaultTestRunner $ testGroup "import-actions" o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))" in ExplicitImports.abbreviateImportTitle i @?= o ] + , testGroup "Title abbreviation squashed" + [ testCase "not abbreviated squashed" $ + let i = "import M (" <> T.replicate 70 "F" <> ", Athing, Bthing, Cthing)" + o = "(FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF, Athing, Bthing, Cthing)" + in ExplicitImports.squashedAbbreviateImportTitle i @?= o + , testCase "abbreviated squashed that drop module name" $ + let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)" + o = "(Athing, Bthing, Cthing)" + in ExplicitImports.squashedAbbreviateImportTitle i @?= o + , testCase "abbreviated squashed in import list" $ + let i = "import M (Athing, Bthing, " <> T.replicate 100 "F" <> ", Cthing, Dthing, Ething)" + o = "(Athing, Bthing, ... (4 items))" + in ExplicitImports.squashedAbbreviateImportTitle i @?= o + ] ]] -- code action tests @@ -162,6 +204,12 @@ notRefineImports (CodeLens _ (Just (Command text _ _)) _) | "Refine imports to" `T.isPrefixOf` text = False notRefineImports _ = True +inlayHintsTest :: FilePath -> Int -> Int -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTest fp l c assert = testCase (fp ++ " inlay hints") $ runSessionWithServer def explicitImportsPlugin testDataDir $ do + doc <- openDoc (fp ++ ".hs") "haskell" + inlayHints <- getInlayHints doc (pointRange l c) + liftIO $ assert inlayHints + -- Execute command and wait for result executeCmd :: Command -> Session () executeCmd cmd = do From a27c5c81e4102b9672cd85b9c13511f734f26dfd Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 19:59:06 +0800 Subject: [PATCH 05/51] Comment inlay hints start position --- .../src/Ide/Plugin/ExplicitImports.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index ef170adef8..bd2c94768a 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -185,6 +185,12 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints where + -- The appropriate and intended position for the hint hints to begin + -- is the end of the range for the code lens. + -- import Data.Char (isSpace) + -- |--- range ----|-- IH ---| + -- |^-padding + -- ^-_position generateInlayHints :: Range -> ImportEdit -> InlayHint generateInlayHints Range {_end} ie = InlayHint { _position = _end From 6b3e5aaeb066346fc0b409eefef2d59e781ed8ee Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 20:01:41 +0800 Subject: [PATCH 06/51] Use `isSubrangeOf` to test if the range is visible --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index bd2c94768a..12d96f6622 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -180,7 +180,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let inlayHints = [ generateInlayHints newRange ie | (range, int) <- forLens - , range < visibleRange + , isSubrangeOf range visibleRange , Just newRange <- [toCurrentRange pm range] , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints From f9f12076c0e619b8c57f3d5adf9f36b689eed46c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 20:03:26 +0800 Subject: [PATCH 07/51] Remove inlayHintsResolveProvider placeholder for now --- .../src/Ide/Plugin/ExplicitImports.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 12d96f6622..d51fbffb53 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -104,7 +104,6 @@ descriptorForModules recorder modFilter plId = <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides inlay hints <> mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder) - -- <> mkResolveHandler SMethod_InlayHintResolve (inlayHintResolveProvider recorder) -- This plugin provides code actions <> codeActionHandlers } From 8e2807652d7375cfe6afcfc2d8dc4b1487dbb1a5 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 20:08:08 +0800 Subject: [PATCH 08/51] Use explicit InlayHintKind_Type --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index d51fbffb53..cac0fbec6e 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -194,7 +194,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif generateInlayHints Range {_end} ie = InlayHint { _position = _end , _label = mkLabel ie - , _kind = Nothing + , _kind = Just InlayHintKind_Type -- for type annotations , _textEdits = Nothing , _tooltip = Nothing , _paddingLeft = Just True From d0f27c28fd44da0278c8cba7fc2aac81489fed48 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 20:16:08 +0800 Subject: [PATCH 09/51] Revert "Update lsp dep by source-repository-package" This reverts commit 245049a58078d7271912a3e12aa16936e6028a11. --- cabal.project | 18 ------------------ ghcide/ghcide.cabal | 2 +- haskell-language-server.cabal | 14 +++++++------- hls-plugin-api/hls-plugin-api.cabal | 2 +- 4 files changed, 9 insertions(+), 27 deletions(-) diff --git a/cabal.project b/cabal.project index 2eb1371a74..d7339b4d80 100644 --- a/cabal.project +++ b/cabal.project @@ -16,24 +16,6 @@ benchmarks: True write-ghc-environment-files: never -source-repository-package - type: git - location: https://github.com/jetjinser/lsp - tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f - subdir: lsp-test - -source-repository-package - type: git - location: https://github.com/jetjinser/lsp - tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f - subdir: lsp - -source-repository-package - type: git - location: https://github.com/jetjinser/lsp - tag: e6d5c5d5b62d4ce4fbdf8cb41d2347507886dd0f - subdir: lsp-types - -- Many of our tests only work single-threaded, and the only way to -- ensure tasty runs everything purely single-threaded is to pass -- this at the top-level diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 2b5be914d4..0d70f31bb7 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -88,7 +88,7 @@ library , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t - , lsp ^>=2.6.0.0 + , lsp ^>=2.5.0.0 , lsp-types ^>=2.2.0.0 , mtl , opentelemetry >=0.6.1 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 92bcc694ab..5f673caafe 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -258,7 +258,7 @@ library hls-cabal-plugin , hls-plugin-api == 2.8.0.0 , hls-graph == 2.8.0.0 , lens - , lsp ^>=2.6 + , lsp ^>=2.5 , lsp-types ^>=2.2 , regex-tdfa ^>=1.3.1 , text @@ -389,7 +389,7 @@ library hls-call-hierarchy-plugin , hiedb ^>= 0.6.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.6 + , lsp >=2.5 , sqlite-simple , text @@ -1002,7 +1002,7 @@ library hls-alternate-number-format-plugin , hls-graph , hls-plugin-api == 2.8.0.0 , lens - , lsp ^>=2.6 + , lsp ^>=2.5 , mtl , regex-tdfa , syb @@ -1232,7 +1232,7 @@ library hls-gadt-plugin , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens - , lsp >=2.6 + , lsp >=2.5 , mtl , text , transformers @@ -1281,7 +1281,7 @@ library hls-explicit-fixity-plugin , ghcide == 2.8.0.0 , hashable , hls-plugin-api == 2.8.0.0 - , lsp >=2.6 + , lsp >=2.5 , text default-extensions: DataKinds @@ -1736,7 +1736,7 @@ library hls-semantic-tokens-plugin , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.6 + , lsp >=2.5 , text , transformers , bytestring @@ -1804,7 +1804,7 @@ library hls-notes-plugin , hls-graph == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.6 + , lsp >=2.5 , mtl >= 2.2 , regex-tdfa >= 1.3.1 , text diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index eef8a7038c..4e8bb6742c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -69,7 +69,7 @@ library , hls-graph == 2.8.0.0 , lens , lens-aeson - , lsp ^>=2.6 + , lsp ^>=2.5 , megaparsec >=9.0 , mtl , opentelemetry >=0.4 From 3e9d5a13ddfbc36f98a36b80f75780063ea1256c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 17 Jun 2024 21:15:15 +0800 Subject: [PATCH 10/51] Combine InlayHints by sconcat them and remove `instance PluginRequestMethod Method_InlayHintResolve` since have not decide how to combine. --- hls-plugin-api/src/Ide/Types.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3699e13d89..e7dfc06f75 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -810,10 +810,7 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentInlayHint where - combineResponses _ _ _ _ (x :| _) = x - -instance PluginRequestMethod Method_InlayHintResolve where - combineResponses _ _ _ _ (x :| _) = x + combineResponses _ _ _ _ x = sconcat x takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) From dbd7508467983bdb263e03de3da349bcf653d994 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 23 Jun 2024 00:03:35 +0800 Subject: [PATCH 11/51] compress multiple spaces in abbr import tilte --- .../src/Ide/Plugin/ExplicitImports.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 1b7d46e128..05634cfb95 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -462,7 +462,8 @@ abbreviateImportTitle :: T.Text -> T.Text abbreviateImportTitle input = let -- For starters, we only want one line in the title - oneLineText = T.unwords $ T.lines input + -- we also need to compress multiple spaces into one + oneLineText = T.unwords $ filter (not . T.null) $ T.split isSpace input -- Now, split at the max columns, leaving space for the summary text we're going to add -- (conservatively assuming we won't need to print a number larger than 100) (prefix, suffix) = T.splitAt (maxColumns - T.length (summaryText 100)) oneLineText From d0fe221ea1d555957f9e9c9e1bb7f317a1604603 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 23 Jun 2024 00:04:49 +0800 Subject: [PATCH 12/51] update test to match inlay hints kind --- .../hls-explicit-imports-plugin/test/Main.hs | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 6ef8731e7c..12f6087f10 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -34,11 +34,11 @@ main = defaultTestRunner $ testGroup "import-actions" "Make imports explicit" [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0 , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0 - , inlayHintsTest "ExplicitUsualCase" 3 0 $ (@=?) + , inlayHintsTest "ExplicitUsualCase" 2 $ (@=?) [InlayHint { _position = Position {_line = 2, _character = 16} , _label = InL "( a1 )" - , _kind = Nothing + , _kind = Just InlayHintKind_Type , _textEdits = Nothing , _tooltip = Nothing , _paddingLeft = Just True @@ -47,11 +47,11 @@ main = defaultTestRunner $ testGroup "import-actions" }] , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0 - , inlayHintsTest "ExplicitOnlyThis" 3 0 $ (@?=) + , inlayHintsTest "ExplicitOnlyThis" 3 $ (@=?) [InlayHint - { _position = Position {_line = 2, _character = 16} - , _label = InL "( a1 )" - , _kind = Nothing + { _position = Position {_line = 3, _character = 16} + , _label = InL "( b1 )" + , _kind = Just InlayHintKind_Type , _textEdits = Nothing , _tooltip = Nothing , _paddingLeft = Just True @@ -60,7 +60,17 @@ main = defaultTestRunner $ testGroup "import-actions" }] , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 , codeActionBreakFile "ExplicitBreakFile" 4 0 - , inlayHintsTest "ExplicitBreakFile" 3 0 $ (@=?) [] + , inlayHintsTest "ExplicitBreakFile" 3 $ (@=?) + [InlayHint + { _position = Position {_line = 3, _character = 16} + , _label = InL "( a1 )" + , _kind = Just InlayHintKind_Type + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + }] , codeActionStaleAction "ExplicitStaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer def explicitImportsPlugin testDataDir $ do @@ -204,11 +214,14 @@ notRefineImports (CodeLens _ (Just (Command text _ _)) _) | "Refine imports to" `T.isPrefixOf` text = False notRefineImports _ = True -inlayHintsTest :: FilePath -> Int -> Int -> ([InlayHint] -> Assertion) -> TestTree -inlayHintsTest fp l c assert = testCase (fp ++ " inlay hints") $ runSessionWithServer def explicitImportsPlugin testDataDir $ do +inlayHintsTest :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTest fp line assert = testCase (fp ++ " inlay hints") $ runSessionWithServer def explicitImportsPlugin testDataDir $ do doc <- openDoc (fp ++ ".hs") "haskell" - inlayHints <- getInlayHints doc (pointRange l c) + inlayHints <- getInlayHints doc (lineRange line) liftIO $ assert inlayHints + where + -- zero-based position + lineRange line = Range (Position line 0) (Position line 1000) -- Execute command and wait for result executeCmd :: Command -> Session () From 75b0ecb37a7f6cbf8650154d46744ece718aa106 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 23 Jun 2024 00:11:34 +0800 Subject: [PATCH 13/51] rename squashedAbbreviateImportTitle to abbreviateImportTitleWithoutModule --- .../src/Ide/Plugin/ExplicitImports.hs | 7 ++++--- plugins/hls-explicit-imports-plugin/test/Main.hs | 14 +++++++------- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 05634cfb95..8a753fa03f 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -11,7 +11,7 @@ module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules , abbreviateImportTitle - , squashedAbbreviateImportTitle + , abbreviateImportTitleWithoutModule , Log(..) ) where @@ -488,8 +488,9 @@ abbreviateImportTitle input = else actualPrefix <> suffixText in title -squashedAbbreviateImportTitle :: T.Text -> T.Text -squashedAbbreviateImportTitle ieText = abbreviateImportTitle $ (T.intercalate " " . filter (not . T.null) . T.split isSpace . T.dropWhile (/= '(')) ieText +-- Create an import abbreviate title without module for inlay hints +abbreviateImportTitleWithoutModule :: Text.Text -> Text.Text +abbreviateImportTitleWithoutModule = abbreviateImportTitle . T.dropWhile (/= '(') -- | The title of the command is ideally the minimal explicit import decl, but -------------------------------------------------------------------------------- diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 12f6087f10..c531e5fd5b 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -110,19 +110,19 @@ main = defaultTestRunner $ testGroup "import-actions" o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))" in ExplicitImports.abbreviateImportTitle i @?= o ] - , testGroup "Title abbreviation squashed" - [ testCase "not abbreviated squashed" $ + , testGroup "Title abbreviation without module" + [ testCase "not abbreviated" $ let i = "import M (" <> T.replicate 70 "F" <> ", Athing, Bthing, Cthing)" o = "(FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF, Athing, Bthing, Cthing)" - in ExplicitImports.squashedAbbreviateImportTitle i @?= o - , testCase "abbreviated squashed that drop module name" $ + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o + , testCase "abbreviated that drop module name" $ let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)" o = "(Athing, Bthing, Cthing)" - in ExplicitImports.squashedAbbreviateImportTitle i @?= o - , testCase "abbreviated squashed in import list" $ + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o + , testCase "abbreviated in import list" $ let i = "import M (Athing, Bthing, " <> T.replicate 100 "F" <> ", Cthing, Dthing, Ething)" o = "(Athing, Bthing, ... (4 items))" - in ExplicitImports.squashedAbbreviateImportTitle i @?= o + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o ] ]] From e0543b9f1721922f012c21613640118805cd23c3 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 23 Jun 2024 00:18:47 +0800 Subject: [PATCH 14/51] Request inlay hints with testEdits --- .../src/Ide/Plugin/ExplicitImports.hs | 40 +++++++++++-------- .../hls-explicit-imports-plugin/test/Main.hs | 6 +-- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 8a753fa03f..feffd3a6b1 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -28,11 +28,13 @@ import Data.Char (isSpace) import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) import Data.IORef (readIORef) +import Data.List (singleton) import qualified Data.Map.Strict as Map import Data.Maybe (isNothing, mapMaybe) import qualified Data.Set as S import Data.String (fromString) import qualified Data.Text as T +import qualified Data.Text as Text import Data.Traversable (for) import qualified Data.Unique as U (hashUnique, newUnique) @@ -112,7 +114,7 @@ runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IARe runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do wedit <- resolveWTextEdit ideState eird _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors - return $ InR Null + return $ InR Null where logErrors (Left re) = do logWith recorder Error (LogWAEResponseError re) pure () @@ -172,14 +174,18 @@ lensResolveProvider _ _ _ _ _ rd = do throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for lens resolve handler: " <> show rd) +-- | Provide explicit imports in inlay hints. +-- Applying textEdits can make the import explicit. +-- There is currently no need to resolve inlay hints, +-- as no tooltips or commands are provided in the label. inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = do nfp <- getNormalizedFilePathE _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp - let inlayHints = [ generateInlayHints newRange ie + let inlayHints = [ generateInlayHints newRange ie pm | (range, int) <- forLens - , isSubrangeOf range visibleRange , Just newRange <- [toCurrentRange pm range] + , isSubrangeOf newRange visibleRange , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints where @@ -189,22 +195,22 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif -- |--- range ----|-- IH ---| -- |^-padding -- ^-_position - generateInlayHints :: Range -> ImportEdit -> InlayHint - generateInlayHints Range {_end} ie = - InlayHint { _position = _end - , _label = mkLabel ie + generateInlayHints :: Range -> ImportEdit -> PositionMapping -> InlayHint + generateInlayHints (Range _ end) ie pm = + InlayHint { _position = end + , _label = InL $ mkLabel ie , _kind = Just InlayHintKind_Type -- for type annotations - , _textEdits = Nothing + , _textEdits = fmap singleton $ toTEdit pm ie , _tooltip = Nothing , _paddingLeft = Just True , _paddingRight = Nothing , _data_ = Nothing } - mkLabel :: ImportEdit -> T.Text |? [InlayHintLabelPart] + mkLabel :: ImportEdit -> T.Text mkLabel (ImportEdit{ieResType, ieText}) = - let title ExplicitImport = squashedAbbreviateImportTitle ieText - title RefineImport = T.intercalate ", " (T.lines ieText) - in InL $ title ieResType + let title ExplicitImport = abbreviateImportTitle . T.dropWhile (/= '(') $ ieText + title RefineImport = "Refine imports to " <> T.intercalate ", " (T.lines ieText) + in title ieResType -- |For explicit imports: If there are any implicit imports, provide both one @@ -273,12 +279,14 @@ resolveWTextEdit ideState (RefineAll uri) = do pure $ mkWorkspaceEdit uri edits pm mkWorkspaceEdit :: Uri -> [ImportEdit] -> PositionMapping -> WorkspaceEdit mkWorkspaceEdit uri edits pm = - WorkspaceEdit {_changes = Just $ Map.singleton uri (mapMaybe toWEdit edits) + WorkspaceEdit {_changes = Just $ Map.singleton uri (mapMaybe (toTEdit pm) edits) , _documentChanges = Nothing , _changeAnnotations = Nothing} - where toWEdit ImportEdit{ieRange, ieText} = - let newRange = toCurrentRange pm ieRange - in (\r -> TextEdit r ieText) <$> newRange + +toTEdit :: PositionMapping -> ImportEdit -> Maybe TextEdit +toTEdit pm ImportEdit{ieRange, ieText} = + let newRange = toCurrentRange pm ieRange + in (\r -> TextEdit r ieText) <$> newRange data ImportActions = ImportActions deriving (Show, Generic, Eq, Ord) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index c531e5fd5b..2467302b91 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -39,7 +39,7 @@ main = defaultTestRunner $ testGroup "import-actions" { _position = Position {_line = 2, _character = 16} , _label = InL "( a1 )" , _kind = Just InlayHintKind_Type - , _textEdits = Nothing + , _textEdits = Just [TextEdit (Range (Position 2 0) (Position 2 16)) "import ExplicitA ( a1 )"] , _tooltip = Nothing , _paddingLeft = Just True , _paddingRight = Nothing @@ -52,7 +52,7 @@ main = defaultTestRunner $ testGroup "import-actions" { _position = Position {_line = 3, _character = 16} , _label = InL "( b1 )" , _kind = Just InlayHintKind_Type - , _textEdits = Nothing + , _textEdits = Just [TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )"] , _tooltip = Nothing , _paddingLeft = Just True , _paddingRight = Nothing @@ -65,7 +65,7 @@ main = defaultTestRunner $ testGroup "import-actions" { _position = Position {_line = 3, _character = 16} , _label = InL "( a1 )" , _kind = Just InlayHintKind_Type - , _textEdits = Nothing + , _textEdits = Just [TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitA ( a1 )"] , _tooltip = Nothing , _paddingLeft = Just True , _paddingRight = Nothing From a6b755601a86fd05067337765f3ab23d84c9fcd5 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 23 Jun 2024 05:02:47 +0800 Subject: [PATCH 15/51] ExplicitImports fallback to codelens when inlay hints not support --- .../src/Ide/Plugin/ExplicitImports.hs | 57 ++++++++++++++----- 1 file changed, 42 insertions(+), 15 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index feffd3a6b1..8297ae15fa 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -58,6 +58,8 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP -- This plugin is named explicit-imports for historical reasons. Besides -- providing code actions and lenses to make imports explicit it also provides @@ -109,6 +111,23 @@ descriptorForModules recorder modFilter plId = <> codeActionHandlers } +isInlayHintsSupported :: MonadIO m => IdeState -> m Bool +isInlayHintsSupported state = do + Shake.ShakeExtras{lspEnv} <- liftIO $ runAction "" state Shake.getShakeExtras + case lspEnv of + Just env -> liftIO $ LSP.runLspT env s + Nothing -> pure False + where + s = do + clientCapabilities <- LSP.getClientCapabilities + pure $ case () of + _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities + , Just LSP.WorkspaceClientCapabilities{_inlayHint} <- _workspace + , Just _ <- _inlayHint + -> True + | otherwise -> False + + -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do @@ -136,13 +155,17 @@ runImportCommand _ _ _ rd = do -- the provider should produce one code lens associated to the import statement: -- > Refine imports to import Control.Monad.IO.Class (liftIO) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens -lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do - nfp <- getNormalizedFilePathE _uri - (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp - let lens = [ generateLens _uri newRange int - | (range, int) <- forLens - , Just newRange <- [toCurrentRange pm range]] - pure $ InL lens +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do + isIHSupported <- liftIO $ isInlayHintsSupported state + if isIHSupported + then do pure $ InR Null + else do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let lens = [ generateLens _uri newRange int + | (range, int) <- forLens + , Just newRange <- [toCurrentRange pm range]] + pure $ InL lens where -- because these are non resolved lenses we only need the range and a -- unique id to later resolve them with. These are for both refine -- import lenses and for explicit import lenses. @@ -180,14 +203,18 @@ lensResolveProvider _ _ _ _ _ rd = do -- as no tooltips or commands are provided in the label. inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = do - nfp <- getNormalizedFilePathE _uri - (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp - let inlayHints = [ generateInlayHints newRange ie pm - | (range, int) <- forLens - , Just newRange <- [toCurrentRange pm range] - , isSubrangeOf newRange visibleRange - , Just ie <- [forResolve IM.!? int]] - pure $ InL inlayHints + isIHSupported <- liftIO $ isInlayHintsSupported state + if isIHSupported + then do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let inlayHints = [ generateInlayHints newRange ie pm + | (range, int) <- forLens + , Just newRange <- [toCurrentRange pm range] + , isSubrangeOf newRange visibleRange + , Just ie <- [forResolve IM.!? int]] + pure $ InL inlayHints + else do pure $ InR Null where -- The appropriate and intended position for the hint hints to begin -- is the end of the range for the code lens. From 2085635778d2339d3171acaf89231ca9a5ca16e9 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 24 Jun 2024 05:52:29 +0800 Subject: [PATCH 16/51] fix explicitImports inlayHints test --- hls-test-utils/src/Test/Hls/Util.hs | 7 +++++++ .../src/Ide/Plugin/ExplicitImports.hs | 4 ++-- plugins/hls-explicit-imports-plugin/test/Main.hs | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index eaba6c595b..d0621ebe3a 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -7,6 +7,7 @@ module Test.Hls.Util ( -- * Test Capabilities codeActionResolveCaps , codeActionNoResolveCaps + , codeActionNoInlayHintsCaps , codeActionSupportCaps , expectCodeAction -- * Environment specifications @@ -107,6 +108,12 @@ codeActionNoResolveCaps :: ClientCapabilities codeActionNoResolveCaps = Test.fullLatestClientCaps & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False + +codeActionNoInlayHintsCaps :: ClientCapabilities +codeActionNoInlayHintsCaps = Test.fullLatestClientCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False + & (L.textDocument . _Just . L.inlayHint) .~ Nothing -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- --------------------------------------------------------------------- diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 8297ae15fa..c0bd2a756f 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -121,8 +121,8 @@ isInlayHintsSupported state = do s = do clientCapabilities <- LSP.getClientCapabilities pure $ case () of - _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities - , Just LSP.WorkspaceClientCapabilities{_inlayHint} <- _workspace + _ | LSP.ClientCapabilities{_textDocument} <- clientCapabilities + , Just LSP.TextDocumentClientCapabilities{_inlayHint} <- _textDocument , Just _ <- _inlayHint -> True | otherwise -> False diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 2467302b91..9da3dc71d0 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -203,7 +203,7 @@ caTitle _ = Nothing -- code lens tests codeLensGoldenTest :: (CodeLens -> Bool) -> FilePath -> Int -> TestTree -codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoResolveCaps $ \doc -> do +codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoInlayHintsCaps $ \doc -> do codeLenses <- getCodeLenses doc resolvedCodeLenses <- for codeLenses resolveCodeLens (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i) From ccf2d8fec435c5b843047f9344f146fc3f635847 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 17:39:02 +0800 Subject: [PATCH 17/51] simplify isInlayHintsSupported --- .../src/Ide/Plugin/ExplicitImports.hs | 22 +++++-------------- 1 file changed, 6 insertions(+), 16 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c0bd2a756f..3d132a593c 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -111,22 +111,12 @@ descriptorForModules recorder modFilter plId = <> codeActionHandlers } -isInlayHintsSupported :: MonadIO m => IdeState -> m Bool -isInlayHintsSupported state = do - Shake.ShakeExtras{lspEnv} <- liftIO $ runAction "" state Shake.getShakeExtras - case lspEnv of - Just env -> liftIO $ LSP.runLspT env s - Nothing -> pure False - where - s = do - clientCapabilities <- LSP.getClientCapabilities - pure $ case () of - _ | LSP.ClientCapabilities{_textDocument} <- clientCapabilities - , Just LSP.TextDocumentClientCapabilities{_inlayHint} <- _textDocument - , Just _ <- _inlayHint - -> True - | otherwise -> False - +isInlayHintsSupported :: Applicative f => IdeState -> f Bool +isInlayHintsSupported ideState = do + let clientCaps = clientCapabilities $ shakeExtras ideState + pure $ case clientCaps of + LSP.ClientCapabilities{_textDocument = Just LSP.TextDocumentClientCapabilities{_inlayHint = Just _}} -> True + _ -> False -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData From fb52cee39fc2a8fa1c3d36559217f09f493e082c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 17:55:17 +0800 Subject: [PATCH 18/51] comment fallback --- .../src/Ide/Plugin/ExplicitImports.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 3d132a593c..0c9b8972fb 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -146,6 +146,8 @@ runImportCommand _ _ _ rd = do -- > Refine imports to import Control.Monad.IO.Class (liftIO) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do + -- Code lens are not provided when the client supports inlay hints, + -- otherwise it will be provided as a fallback isIHSupported <- liftIO $ isInlayHintsSupported state if isIHSupported then do pure $ InR Null @@ -204,6 +206,8 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , isSubrangeOf newRange visibleRange , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints + -- When the client does not support inlay hints, fallback to the code lens, + -- so this is Null else do pure $ InR Null where -- The appropriate and intended position for the hint hints to begin From 6e5f746b3f13b7c84c1d11d75bca133c8dd5c310 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 18:38:10 +0800 Subject: [PATCH 19/51] empty list instead of null codeLens --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0c9b8972fb..deb9f0db31 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -150,7 +150,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_ -- otherwise it will be provided as a fallback isIHSupported <- liftIO $ isInlayHintsSupported state if isIHSupported - then do pure $ InR Null + then do pure $ InL [] else do nfp <- getNormalizedFilePathE _uri (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp From f4c2ea24c78138b62827786467fb6b987db0daf6 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 18:39:21 +0800 Subject: [PATCH 20/51] clearify name `paddingLeft` --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index deb9f0db31..dea783bc85 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -214,7 +214,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif -- is the end of the range for the code lens. -- import Data.Char (isSpace) -- |--- range ----|-- IH ---| - -- |^-padding + -- |^-paddingLeft -- ^-_position generateInlayHints :: Range -> ImportEdit -> PositionMapping -> InlayHint generateInlayHints (Range _ end) ie pm = From 62a51cec885d3e4317df00c2762c5cd33903e773 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 18:45:09 +0800 Subject: [PATCH 21/51] fix clientCapabilities --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index dea783bc85..0c3e229641 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -113,7 +113,7 @@ descriptorForModules recorder modFilter plId = isInlayHintsSupported :: Applicative f => IdeState -> f Bool isInlayHintsSupported ideState = do - let clientCaps = clientCapabilities $ shakeExtras ideState + let clientCaps = Shake.clientCapabilities $ shakeExtras ideState pure $ case clientCaps of LSP.ClientCapabilities{_textDocument = Just LSP.TextDocumentClientCapabilities{_inlayHint = Just _}} -> True _ -> False From f70e402ea92383645412108d900e57c4414512ed Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 25 Jun 2024 21:59:01 +0800 Subject: [PATCH 22/51] add test for inlay hints without its client caps --- .../hls-explicit-imports-plugin/test/Main.hs | 76 ++++++++++--------- 1 file changed, 41 insertions(+), 35 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 9da3dc71d0..fc3a8f4692 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -34,43 +34,22 @@ main = defaultTestRunner $ testGroup "import-actions" "Make imports explicit" [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0 , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0 - , inlayHintsTest "ExplicitUsualCase" 2 $ (@=?) - [InlayHint - { _position = Position {_line = 2, _character = 16} - , _label = InL "( a1 )" - , _kind = Just InlayHintKind_Type - , _textEdits = Just [TextEdit (Range (Position 2 0) (Position 2 16)) "import ExplicitA ( a1 )"] - , _tooltip = Nothing - , _paddingLeft = Just True - , _paddingRight = Nothing - , _data_ = Nothing - }] + , inlayHintsTestWithCap "ExplicitUsualCase" 2 $ (@=?) + [mkInlayHint (Position 2 16) "( a1 )" + (TextEdit (Range (Position 2 0) (Position 2 16)) "import ExplicitA ( a1 )")] + , inlayHintsTestWithoutCap "ExplicitUsualCase" 2 $ (@=?) [] , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0 - , inlayHintsTest "ExplicitOnlyThis" 3 $ (@=?) - [InlayHint - { _position = Position {_line = 3, _character = 16} - , _label = InL "( b1 )" - , _kind = Just InlayHintKind_Type - , _textEdits = Just [TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )"] - , _tooltip = Nothing - , _paddingLeft = Just True - , _paddingRight = Nothing - , _data_ = Nothing - }] + , inlayHintsTestWithCap "ExplicitOnlyThis" 3 $ (@=?) + [mkInlayHint (Position 3 16) "( b1 )" + (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )")] + , inlayHintsTestWithoutCap "ExplicitOnlyThis" 3 $ (@=?) [] , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 , codeActionBreakFile "ExplicitBreakFile" 4 0 - , inlayHintsTest "ExplicitBreakFile" 3 $ (@=?) - [InlayHint - { _position = Position {_line = 3, _character = 16} - , _label = InL "( a1 )" - , _kind = Just InlayHintKind_Type - , _textEdits = Just [TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitA ( a1 )"] - , _tooltip = Nothing - , _paddingLeft = Just True - , _paddingRight = Nothing - , _data_ = Nothing - }] + , inlayHintsTestWithCap "ExplicitBreakFile" 3 $ (@=?) + [mkInlayHint (Position 3 16) "( a1 )" + (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitA ( a1 )")] + , inlayHintsTestWithoutCap "ExplicitBreakFile" 3 $ (@=?) [] , codeActionStaleAction "ExplicitStaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer def explicitImportsPlugin testDataDir $ do @@ -214,14 +193,41 @@ notRefineImports (CodeLens _ (Just (Command text _ _)) _) | "Refine imports to" `T.isPrefixOf` text = False notRefineImports _ = True -inlayHintsTest :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree -inlayHintsTest fp line assert = testCase (fp ++ " inlay hints") $ runSessionWithServer def explicitImportsPlugin testDataDir $ do +-- inlay hints tests + +inlayHintsTest :: ClientCapabilities -> String -> FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTest configCaps postfix fp line assert = testCase (fp ++ postfix) $ run $ \_ -> do doc <- openDoc (fp ++ ".hs") "haskell" inlayHints <- getInlayHints doc (lineRange line) liftIO $ assert inlayHints where -- zero-based position lineRange line = Range (Position line 0) (Position line 1000) + run = runSessionWithTestConfig def + { testDirLocation = Left testDataDir + , testPluginDescriptor = explicitImportsPlugin + , testConfigCaps = configCaps + } + +inlayHintsTestWithCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTestWithCap = inlayHintsTest fullLatestClientCaps " inlay hints with client caps" + +inlayHintsTestWithoutCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTestWithoutCap = inlayHintsTest codeActionNoInlayHintsCaps " inlay hints without client caps" + + +mkInlayHint :: Position -> Text -> TextEdit -> InlayHint +mkInlayHint pos label textEdit = + InlayHint + { _position = pos + , _label = InL label + , _kind = Just InlayHintKind_Type + , _textEdits = Just [textEdit] + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + } -- Execute command and wait for result executeCmd :: Command -> Session () From 57ef0db59e55525e73ea6bead344d3c92544236a Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Fri, 28 Jun 2024 19:28:26 +0800 Subject: [PATCH 23/51] use codeActionNoInlayHintsCaps to avoid error --- plugins/hls-explicit-imports-plugin/test/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index fc3a8f4692..0fcc494830 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -115,7 +115,9 @@ codeActionAllGoldenTest fp l c = goldenWithImportActions " code action" fp codeA _ -> liftIO $ assertFailure "Unable to find CodeAction" codeActionBreakFile :: FilePath -> Int -> Int -> TestTree -codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do +-- If use `codeActionNoResolveCaps` instead of `codeActionNoInlayHintsCaps` here, +-- we will get a puzzling error: https://github.com/haskell/haskell-language-server/pull/4235#issuecomment-2189048997 +codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoInlayHintsCaps $ \doc -> do _ <- getCodeLenses doc changeDoc doc [edit] actions <- getCodeActions doc (pointRange l c) From f8b19930addf7104167b45f78f29ac6371570b9a Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 03:35:02 +0800 Subject: [PATCH 24/51] simplify isInlayHintSupported --- .../src/Ide/Plugin/ExplicitImports.hs | 23 ++++++++----------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0c3e229641..f591277a30 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -16,7 +16,7 @@ module Ide.Plugin.ExplicitImports ) where import Control.DeepSeq -import Control.Lens ((&), (?~)) +import Control.Lens (_Just, (&), (?~), (^?)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) @@ -30,7 +30,8 @@ import qualified Data.IntMap as IM (IntMap, elems, import Data.IORef (readIORef) import Data.List (singleton) import qualified Data.Map.Strict as Map -import Data.Maybe (isNothing, mapMaybe) +import Data.Maybe (isJust, isNothing, + mapMaybe) import qualified Data.Set as S import Data.String (fromString) import qualified Data.Text as T @@ -55,11 +56,11 @@ import qualified Ide.Plugin.RangeMap as RM (RangeMap, import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types +import Language.LSP.Protocol.Lens (HasInlayHint (inlayHint), + HasTextDocument (textDocument)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Server as LSP -- This plugin is named explicit-imports for historical reasons. Besides -- providing code actions and lenses to make imports explicit it also provides @@ -111,12 +112,10 @@ descriptorForModules recorder modFilter plId = <> codeActionHandlers } -isInlayHintsSupported :: Applicative f => IdeState -> f Bool -isInlayHintsSupported ideState = do +isInlayHintsSupported :: IdeState -> Bool +isInlayHintsSupported ideState = let clientCaps = Shake.clientCapabilities $ shakeExtras ideState - pure $ case clientCaps of - LSP.ClientCapabilities{_textDocument = Just LSP.TextDocumentClientCapabilities{_inlayHint = Just _}} -> True - _ -> False + in isJust $ clientCaps ^? textDocument . _Just . inlayHint . _Just -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData @@ -148,8 +147,7 @@ lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Met lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do -- Code lens are not provided when the client supports inlay hints, -- otherwise it will be provided as a fallback - isIHSupported <- liftIO $ isInlayHintsSupported state - if isIHSupported + if isInlayHintsSupported state then do pure $ InL [] else do nfp <- getNormalizedFilePathE _uri @@ -195,8 +193,7 @@ lensResolveProvider _ _ _ _ _ rd = do -- as no tooltips or commands are provided in the label. inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = do - isIHSupported <- liftIO $ isInlayHintsSupported state - if isIHSupported + if isInlayHintsSupported state then do nfp <- getNormalizedFilePathE _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp From a50b148593d96cd7f25ac56e097220929f1fd616 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 04:04:03 +0800 Subject: [PATCH 25/51] comment about paddingLeft --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index f591277a30..fd9709deae 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -220,7 +220,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , _kind = Just InlayHintKind_Type -- for type annotations , _textEdits = fmap singleton $ toTEdit pm ie , _tooltip = Nothing - , _paddingLeft = Just True + , _paddingLeft = Just True -- show an extra space before the inlay hint , _paddingRight = Nothing , _data_ = Nothing } From af635f70e08db91480517d2e1d60657a6732d3c0 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 04:10:34 +0800 Subject: [PATCH 26/51] use null as inlay hints kind --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- plugins/hls-explicit-imports-plugin/test/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index fd9709deae..40226b1373 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -217,7 +217,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif generateInlayHints (Range _ end) ie pm = InlayHint { _position = end , _label = InL $ mkLabel ie - , _kind = Just InlayHintKind_Type -- for type annotations + , _kind = Nothing -- neither a type nor a parameter , _textEdits = fmap singleton $ toTEdit pm ie , _tooltip = Nothing , _paddingLeft = Just True -- show an extra space before the inlay hint diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 0fcc494830..9c11525dcc 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -223,7 +223,7 @@ mkInlayHint pos label textEdit = InlayHint { _position = pos , _label = InL label - , _kind = Just InlayHintKind_Type + , _kind = Nothing , _textEdits = Just [textEdit] , _tooltip = Nothing , _paddingLeft = Just True From 0fab728b76260c8bb75c13b10e12b20bd53383df Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 04:24:16 +0800 Subject: [PATCH 27/51] add tooltip for explicit imports inlay hints to improve UX --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- plugins/hls-explicit-imports-plugin/test/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 40226b1373..e7ceb91f85 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -219,7 +219,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , _label = InL $ mkLabel ie , _kind = Nothing -- neither a type nor a parameter , _textEdits = fmap singleton $ toTEdit pm ie - , _tooltip = Nothing + , _tooltip = Just $ InL "Make this import explicit" -- simple enough, no need to resolve , _paddingLeft = Just True -- show an extra space before the inlay hint , _paddingRight = Nothing , _data_ = Nothing diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 9c11525dcc..a4004cb319 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -225,7 +225,7 @@ mkInlayHint pos label textEdit = , _label = InL label , _kind = Nothing , _textEdits = Just [textEdit] - , _tooltip = Nothing + , _tooltip = Just $ InL "Make this import explicit" , _paddingLeft = Just True , _paddingRight = Nothing , _data_ = Nothing From 4c7313d509c7e6b537af716cd1594e1d1a1e6f3e Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 04:25:01 +0800 Subject: [PATCH 28/51] chore comments --- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index e7ceb91f85..7b3a85706e 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -211,7 +211,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif -- is the end of the range for the code lens. -- import Data.Char (isSpace) -- |--- range ----|-- IH ---| - -- |^-paddingLeft + -- |^-_paddingLeft -- ^-_position generateInlayHints :: Range -> ImportEdit -> PositionMapping -> InlayHint generateInlayHints (Range _ end) ie pm = From ffdb94c8750f8abbaacecce69ceab0c774a74b4c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 30 Jun 2024 04:42:35 +0800 Subject: [PATCH 29/51] refactor --- .../src/Ide/Plugin/ExplicitImports.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 7b3a85706e..d467a9ea59 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -148,7 +148,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_ -- Code lens are not provided when the client supports inlay hints, -- otherwise it will be provided as a fallback if isInlayHintsSupported state - then do pure $ InL [] + then pure $ InL [] else do nfp <- getNormalizedFilePathE _uri (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp @@ -192,7 +192,7 @@ lensResolveProvider _ _ _ _ _ rd = do -- There is currently no need to resolve inlay hints, -- as no tooltips or commands are provided in the label. inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint -inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = do +inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = if isInlayHintsSupported state then do nfp <- getNormalizedFilePathE _uri @@ -205,7 +205,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif pure $ InL inlayHints -- When the client does not support inlay hints, fallback to the code lens, -- so this is Null - else do pure $ InR Null + else pure $ InR Null where -- The appropriate and intended position for the hint hints to begin -- is the end of the range for the code lens. @@ -226,7 +226,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif } mkLabel :: ImportEdit -> T.Text mkLabel (ImportEdit{ieResType, ieText}) = - let title ExplicitImport = abbreviateImportTitle . T.dropWhile (/= '(') $ ieText + let title ExplicitImport = abbreviateImportTitleWithoutModule ieText title RefineImport = "Refine imports to " <> T.intercalate ", " (T.lines ieText) in title ieResType From 0a876c3f09de3ad4a13d7f1151ba97a3e59da705 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 2 Jul 2024 02:23:22 +0800 Subject: [PATCH 30/51] comment InL [] to indicate no info --- .../src/Ide/Plugin/ExplicitImports.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index d467a9ea59..8abdc5933b 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -148,6 +148,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_ -- Code lens are not provided when the client supports inlay hints, -- otherwise it will be provided as a fallback if isInlayHintsSupported state + -- `[]` is no different from `null`, we chose to use all `[]` to indicate "no information" then pure $ InL [] else do nfp <- getNormalizedFilePathE _uri @@ -204,8 +205,8 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , Just ie <- [forResolve IM.!? int]] pure $ InL inlayHints -- When the client does not support inlay hints, fallback to the code lens, - -- so this is Null - else pure $ InR Null + -- so there is nothing to response here, return `[]` to indicate "no information" + else pure $ InL [] where -- The appropriate and intended position for the hint hints to begin -- is the end of the range for the code lens. From c11e3562424a4a6147214b06933bf83e22ef0c1b Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 2 Jul 2024 02:32:17 +0800 Subject: [PATCH 31/51] ignore refine inlay hints --- .../src/Ide/Plugin/ExplicitImports.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 8abdc5933b..fbd06c405c 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -25,6 +25,7 @@ import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) import Data.Char (isSpace) +import Data.Functor ((<&>)) import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) import Data.IORef (readIORef) @@ -198,11 +199,12 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif then do nfp <- getNormalizedFilePathE _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp - let inlayHints = [ generateInlayHints newRange ie pm + let inlayHints = [ inlayHint | (range, int) <- forLens , Just newRange <- [toCurrentRange pm range] , isSubrangeOf newRange visibleRange - , Just ie <- [forResolve IM.!? int]] + , Just ie <- [forResolve IM.!? int] + , Just inlayHint <- [generateInlayHints newRange ie pm]] pure $ InL inlayHints -- When the client does not support inlay hints, fallback to the code lens, -- so there is nothing to response here, return `[]` to indicate "no information" @@ -214,10 +216,10 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif -- |--- range ----|-- IH ---| -- |^-_paddingLeft -- ^-_position - generateInlayHints :: Range -> ImportEdit -> PositionMapping -> InlayHint - generateInlayHints (Range _ end) ie pm = + generateInlayHints :: Range -> ImportEdit -> PositionMapping -> Maybe InlayHint + generateInlayHints (Range _ end) ie pm = mkLabel ie <&> \label -> InlayHint { _position = end - , _label = InL $ mkLabel ie + , _label = InL label , _kind = Nothing -- neither a type nor a parameter , _textEdits = fmap singleton $ toTEdit pm ie , _tooltip = Just $ InL "Make this import explicit" -- simple enough, no need to resolve @@ -225,10 +227,10 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif , _paddingRight = Nothing , _data_ = Nothing } - mkLabel :: ImportEdit -> T.Text + mkLabel :: ImportEdit -> Maybe T.Text mkLabel (ImportEdit{ieResType, ieText}) = - let title ExplicitImport = abbreviateImportTitleWithoutModule ieText - title RefineImport = "Refine imports to " <> T.intercalate ", " (T.lines ieText) + let title ExplicitImport = Just $ abbreviateImportTitleWithoutModule ieText + title RefineImport = Nothing -- does not provide imports statements that can be refined via inlay hints in title ieResType From 599ebcf06c9cb8a09302d7be452657a4204870f6 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 2 Jul 2024 05:06:14 +0800 Subject: [PATCH 32/51] add plcInlayHintsOn config --- hls-plugin-api/src/Ide/Plugin/Config.hs | 5 +++-- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 ++ hls-plugin-api/src/Ide/Types.hs | 9 ++++++--- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 24c1b0c376..019b552b52 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -63,19 +63,20 @@ parsePlugins (IdePlugins plugins) = A.withObject "Config.plugins" $ \o -> do -- --------------------------------------------------------------------- parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig -parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig +parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def + <*> o .:? "inlayHintsOn" .!= plcInlayHintsOn 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 .:? "foldingRangeOn" .!= plcFoldingRangeOn def + <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 1dbc97a202..8ee6110d29 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -88,6 +88,7 @@ pluginsToDefaultConfig IdePlugins {..} = handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn] + SMethod_TextDocumentInlayHint -> ["inlayHintsOn" A..= plcInlayHintsOn] SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] @@ -120,6 +121,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions" plcCodeActionsOn] SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses" plcCodeLensOn] + SMethod_TextDocumentInlayHint -> [toKey' "inlayHintsOn" A..= schemaEntry "inlay hints" plcInlayHintsOn] SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn] SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn] SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn] diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 46d2e35e37..fac6cd6b6b 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -260,6 +260,7 @@ data PluginConfig = , plcCallHierarchyOn :: !Bool , plcCodeActionsOn :: !Bool , plcCodeLensOn :: !Bool + , plcInlayHintsOn :: !Bool , plcDiagnosticsOn :: !Bool , plcHoverOn :: !Bool , plcSymbolsOn :: !Bool @@ -277,6 +278,7 @@ instance Default PluginConfig where , plcCallHierarchyOn = True , plcCodeActionsOn = True , plcCodeLensOn = True + , plcInlayHintsOn = True , plcDiagnosticsOn = True , plcHoverOn = True , plcSymbolsOn = True @@ -289,12 +291,13 @@ instance Default PluginConfig where } instance ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn sr fr st cfg) = r + toJSON (PluginConfig g ch ca ih cl d h s c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch , "codeActionsOn" .= ca , "codeLensOn" .= cl + , "inlayHintsOn" .= ih , "diagnosticsOn" .= d , "hoverOn" .= h , "symbolsOn" .= s @@ -512,10 +515,10 @@ instance PluginMethod Request Method_WorkspaceSymbol where handlesRequest _ _ _ _ = HandlesRequest instance PluginMethod Request Method_TextDocumentInlayHint where - handlesRequest _ _ _ _ = HandlesRequest + handlesRequest = pluginEnabledWithFeature plcInlayHintsOn instance PluginMethod Request Method_InlayHintResolve where - handlesRequest _ _ _ _ = HandlesRequest + handlesRequest = pluginEnabledResolve plcInlayHintsOn instance PluginMethod Request Method_TextDocumentCodeLens where handlesRequest = pluginEnabledWithFeature plcCodeLensOn From 3e5b88f7a26292fa5d5af2c1cea6c7163855ff7e Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 2 Jul 2024 13:59:39 +0800 Subject: [PATCH 33/51] update func-test --- test/testdata/schema/ghc94/default-config.golden.json | 3 ++- .../schema/ghc94/vscode-extension-schema.golden.json | 6 ++++++ test/testdata/schema/ghc96/default-config.golden.json | 3 ++- .../schema/ghc96/vscode-extension-schema.golden.json | 6 ++++++ test/testdata/schema/ghc98/default-config.golden.json | 3 ++- .../schema/ghc98/vscode-extension-schema.golden.json | 6 ++++++ 6 files changed, 24 insertions(+), 3 deletions(-) diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 2859e3d720..2612bdba87 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -93,7 +93,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index d113264901..03371d21e7 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -213,6 +213,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.moduleName.globalOn": { "default": true, "description": "Enables moduleName plugin", diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 2859e3d720..2612bdba87 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -93,7 +93,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index d113264901..03371d21e7 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -213,6 +213,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.moduleName.globalOn": { "default": true, "description": "Enables moduleName plugin", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 2859e3d720..2612bdba87 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -93,7 +93,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index d113264901..03371d21e7 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -213,6 +213,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.moduleName.globalOn": { "default": true, "description": "Enables moduleName plugin", From 6cfafd5a11e5f06e30249c857e6425ae19870090 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 2 Jul 2024 15:05:07 +0800 Subject: [PATCH 34/51] keep order to make Parser works --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 019b552b52..4fee92c309 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -66,7 +66,6 @@ parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def - <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def <*> o .:? "inlayHintsOn" .!= plcInlayHintsOn def @@ -77,6 +76,7 @@ parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def + <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- From ce761e72062792b59446c694bc6c0eb34239ad87 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 6 Jul 2024 00:46:44 +0800 Subject: [PATCH 35/51] always provide refine in code lens --- .../src/Ide/Plugin/ExplicitImports.hs | 33 ++++++++++--------- .../hls-explicit-imports-plugin/test/Main.hs | 15 +++++---- 2 files changed, 26 insertions(+), 22 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 56e695f4b9..611c02fc78 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -146,18 +146,18 @@ runImportCommand _ _ _ rd = do -- > Refine imports to import Control.Monad.IO.Class (liftIO) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do - -- Code lens are not provided when the client supports inlay hints, - -- otherwise it will be provided as a fallback - if isInlayHintsSupported state - -- `[]` is no different from `null`, we chose to use all `[]` to indicate "no information" - then pure $ InL [] - else do - nfp <- getNormalizedFilePathE _uri - (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp - let lens = [ generateLens _uri newRange int - | (range, int) <- forLens - , Just newRange <- [toCurrentRange pm range]] - pure $ InL lens + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let lens = [ generateLens _uri newRange int + -- provide ExplicitImport only if the client does not support inlay hints + | not (isInlayHintsSupported state) + , (range, (int, ExplicitImport)) <- forLens + , Just newRange <- [toCurrentRange pm range]] <> + -- RefineImport is always provided because inlay hints cannot + [ generateLens _uri newRange int + | (range, (int, RefineImport)) <- forLens + , Just newRange <- [toCurrentRange pm range]] + pure $ InL lens where -- because these are non resolved lenses we only need the range and a -- unique id to later resolve them with. These are for both refine -- import lenses and for explicit import lenses. @@ -200,14 +200,15 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif nfp <- getNormalizedFilePathE _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let inlayHints = [ inlayHint - | (range, int) <- forLens + | (range, (int, _)) <- forLens , Just newRange <- [toCurrentRange pm range] , isSubrangeOf newRange visibleRange , Just ie <- [forResolve IM.!? int] , Just inlayHint <- [generateInlayHints newRange ie pm]] pure $ InL inlayHints -- When the client does not support inlay hints, fallback to the code lens, - -- so there is nothing to response here, return `[]` to indicate "no information" + -- so there is nothing to response here. + -- `[]` is no different from `null`, we chose to use all `[]` to indicate "no information" else pure $ InL [] where -- The appropriate and intended position for the hint hints to begin @@ -325,7 +326,7 @@ data ImportActionsResult = ImportActionsResult { -- |For providing the code lenses we need to have a range, and a unique id -- that is later resolved to the new text for each import. It is stored in -- a list, because we always need to provide all the code lens in a file. - forLens :: [(Range, Int)] + forLens :: [(Range, (Int, ResultType))] -- |For the code actions we have the same data as for the code lenses, but -- we store it in a RangeMap, because that allows us to filter on a specific -- range with better performance, and code actions are almost always only @@ -417,7 +418,7 @@ minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogSha pure (u, rt) let rangeAndUnique = [ ImportAction r u rt | (u, (r, (_, rt))) <- uniqueAndRangeAndText ] pure ImportActionsResult - { forLens = (\ImportAction{..} -> (iaRange, iaUniqueId)) <$> rangeAndUnique + { forLens = (\ImportAction{..} -> (iaRange, (iaUniqueId, iaResType))) <$> rangeAndUnique , forCodeActions = RM.fromList iaRange rangeAndUnique , forResolve = IM.fromList ((\(u, (r, (te, ty))) -> (u, ImportEdit r te ty)) <$> uniqueAndRangeAndText) } diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index a4004cb319..440010bad2 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -26,9 +26,10 @@ main = defaultTestRunner $ testGroup "import-actions" [testGroup "Refine Imports" [ codeActionGoldenTest "RefineWithOverride" 3 1 - , codeLensGoldenTest isRefineImports "RefineUsualCase" 1 - , codeLensGoldenTest isRefineImports "RefineQualified" 0 - , codeLensGoldenTest isRefineImports "RefineQualifiedExplicit" 0 + -- Although the client has inlay hints caps, refine is always provided by the code lens + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineUsualCase" 1 + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualified" 0 + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualifiedExplicit" 0 ], testGroup "Make imports explicit" @@ -44,7 +45,9 @@ main = defaultTestRunner $ testGroup "import-actions" [mkInlayHint (Position 3 16) "( b1 )" (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )")] , inlayHintsTestWithoutCap "ExplicitOnlyThis" 3 $ (@=?) [] - , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 + -- Only when the client does not support inlay hints, explicit will be provided by code lens + , codeLensGoldenTest codeActionNoInlayHintsCaps notRefineImports "ExplicitUsualCase" 0 + , expectFail $ codeLensGoldenTest codeActionNoResolveCaps notRefineImports "ExplicitUsualCase" 0 , codeActionBreakFile "ExplicitBreakFile" 4 0 , inlayHintsTestWithCap "ExplicitBreakFile" 3 $ (@=?) [mkInlayHint (Position 3 16) "( a1 )" @@ -183,8 +186,8 @@ caTitle _ = Nothing -- code lens tests -codeLensGoldenTest :: (CodeLens -> Bool) -> FilePath -> Int -> TestTree -codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoInlayHintsCaps $ \doc -> do +codeLensGoldenTest :: ClientCapabilities -> (CodeLens -> Bool) -> FilePath -> Int -> TestTree +codeLensGoldenTest caps predicate fp i = goldenWithImportActions " code lens" fp caps $ \doc -> do codeLenses <- getCodeLenses doc resolvedCodeLenses <- for codeLenses resolveCodeLens (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i) From d1451b8e4c01938bfb647f57e39dcf4371be98c0 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 7 Jul 2024 18:17:52 +0800 Subject: [PATCH 36/51] init explicit record fields inlay hints --- .../src/Ide/Plugin/ExplicitFields.hs | 161 ++++++++++++---- .../test/Main.hs | 179 ++++++++++++++++-- 2 files changed, 292 insertions(+), 48 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index a1a2017c8d..00303f774b 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor @@ -19,17 +20,19 @@ import Data.Generics (GenericQ, everything, everythingBut, extQ, mkQ) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, +import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList) import Data.Text (Text) import Data.Unique (hashUnique, newUnique) import Control.Monad (replicateM) -import Development.IDE (IdeState, Pretty (..), Range, - Recorder (..), Rules, - WithPriority (..), +import Data.List (intersperse) +import Development.IDE (IdeState, Pretty (..), + Range (_end), Recorder (..), + Rules, WithPriority (..), defineNoDiagnostics, - realSrcSpanToRange, viaShow) + realSrcSpanToRange, + srcSpanToRange, viaShow) import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -71,14 +74,21 @@ import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, ResolveFunction, - defaultPluginDescriptor) + defaultPluginDescriptor, + mkPluginHandler) import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..)) +import Language.LSP.Protocol.Message (Method (..), + SMethod (SMethod_TextDocumentInlayHint)) import Language.LSP.Protocol.Types (CodeAction (..), CodeActionKind (CodeActionKind_RefactorRewrite), - CodeActionParams (..), - Command, TextEdit (..), + CodeActionParams (CodeActionParams), + Command, InlayHint (..), + InlayHintLabelPart (InlayHintLabelPart), + InlayHintParams (InlayHintParams, _range, _textDocument), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), + isSubrangeOf, type (|?) (InL, InR)) #if __GLASGOW_HASKELL__ < 910 @@ -105,8 +115,9 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = let resolveRecorder = cmapWithPrio LogResolve recorder (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + ihHandlers = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder) in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit") - { pluginHandlers = caHandlers + { pluginHandlers = caHandlers <> ihHandlers , pluginCommands = carCommands , pluginRules = collectRecordsRule recorder *> collectNamesRule } @@ -120,12 +131,9 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions where - mkCodeAction :: [Extension] -> Int -> Command |? CodeAction - mkCodeAction exts uid = InR CodeAction - { _title = "Expand record wildcard" - <> if NamedFieldPuns `elem` exts - then mempty - else " (needs extension: NamedFieldPuns)" + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = mkTitle exts , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing @@ -144,17 +152,61 @@ codeActionResolveProvider ideState pId ca uri uid = do -- that this resolve is stale. record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve -- We should never fail to render - rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record let edits = [rendered] <> maybeToList (pragmaEdit enabledExtensions pragma) pure $ ca & L.edit ?~ mkWorkspaceEdit edits where mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing - pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit - pragmaEdit exts pragma = if NamedFieldPuns `elem` exts - then Nothing - else Just $ insertNewPragma pragma NamedFieldPuns + +inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId state nfp + crr@CRR{crCodeActions, crCodeActionResolve} <- runActionE "ExplicitFields.CollectRecords" state $ useE CollectRecords nfp + let records = [ record + | uid <- filterByRange' visibleRange crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] + ] + in pure $ InL $ mapMaybe (mkInlayHints crr pragma) records + where + mkInlayHints CRR {enabledExtensions, nameMap} pragma record = + let end = fmap _end $ recordInfoToDotDotRange record -- TODO: consider position + -- TODO: consider textEdits + textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record) + <> maybeToList (pragmaEdit enabledExtensions pragma) + labels = renderRecordInfoAsInlayHintLabel record + in do + pos <- end + lbls <- labels + let lbl = intersperse (mkInlayHintLabelPart ", ") $ fmap mkInlayHintLabelPart lbls + pure $ InlayHint { _position = pos + , _label = InR lbl + , _kind = Nothing -- neither a type nor a parameter + , _textEdits = Just textEdits + , _tooltip = Just $ InL (mkTitle enabledExtensions) + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + filterByRange' range = map snd . filter (flip isSubrangeOf range . fst) . RangeMap.unRangeMap + -- TODO: tooltip: display hover info, need resolve + mkInlayHintLabelPart value = InlayHintLabelPart value Nothing Nothing Nothing + + +mkTitle :: [Extension] -> Text +mkTitle exts = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" + + +pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit +pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns + collectRecordsRule :: Recorder (WithPriority Log) -> Rules () collectRecordsRule recorder = @@ -261,9 +313,21 @@ recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss -renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit -renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat -renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr +-- TODO: better name for those, not sure + +recordInfoToDotDotRange :: RecordInfo -> Maybe Range +recordInfoToDotDotRange (RecordInfoPat _ (ConPat _ _ (RecCon flds))) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange (RecordInfoCon _ (RecordCon _ _ flds)) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange _ = Nothing + +renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit +renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr + +renderRecordInfoAsInlayHintLabel :: RecordInfo -> Maybe [Text] +renderRecordInfoAsInlayHintLabel (RecordInfoPat _ pat) = showRecordPatFlds pat +renderRecordInfoAsInlayHintLabel (RecordInfoCon _ expr) = showRecordConFlds expr + -- | Checks if a 'Name' is referenced in the given map of names. The -- 'hasNonBindingOcc' check is necessary in order to make sure that only the @@ -281,16 +345,16 @@ referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + preprocessRecordPat :: p ~ GhcPass 'Renamed => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) - where - getFieldName x = case unLoc (hfbRHS x) of - VarPat _ x' -> Just $ unLoc x' - _ -> Nothing + where getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg @@ -333,17 +397,44 @@ preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = r punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed +processRecordFlds + :: p ~ GhcPass c + => HsRecFields p arg + -> HsRecFields p arg +processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' } + where + no_pun_count = fromMaybe (length (rec_flds flds)) (recDotDot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be drop + puns = drop no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + + showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) +showRecordPatFlds :: Pat (GhcPass 'Renamed) -> Maybe [Text] +showRecordPatFlds (ConPat _ _ args) = fmap (fmap printOutputable . rec_flds) (m args) + where + m (RecCon flds) = Just $ processRecordFlds flds + m _ = Nothing +showRecordPatFlds _ = Nothing + showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text showRecordCon expr@(RecordCon _ _ flds) = Just $ printOutputable $ expr { rcon_flds = preprocessRecordCon flds } showRecordCon _ = Nothing +showRecordConFlds :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe [Text] +showRecordConFlds (RecordCon _ _ flds) = Just $ fmap printOutputable (rec_flds $ processRecordFlds flds) +showRecordConFlds _ = Nothing + + collectRecords :: GenericQ [RecordInfo] collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index f8e53e44a1..581d2f455b 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -4,6 +4,7 @@ module Main ( main ) where import Data.Either (rights) +import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitFields as ExplicitFields import System.FilePath ((<.>), ()) @@ -17,21 +18,128 @@ plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" test :: TestTree test = testGroup "explicit-fields" - [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 - , mkTest "Unused" "Unused" 12 10 12 20 - , mkTest "Unused2" "Unused2" 12 10 12 20 - , mkTest "WithPun" "WithPun" 13 10 13 25 - , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 - , mkTest "Mixed" "Mixed" 14 10 14 37 - , mkTest "Construction" "Construction" 16 5 16 15 - , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 - , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 - , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 - , mkTestNoAction "Puns" "Puns" 12 10 12 31 - , mkTestNoAction "Infix" "Infix" 11 11 11 31 - , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + [ testGroup "code actions" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 + , mkTest "Unused2" "Unused2" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 14 10 14 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + ] + , testGroup "inlay hints" + [ mkInlayHintsTest "Construction" 16 $ (@=?) + [defInlayHint { _position = Position 16 14 + , _label = InR [ mkLabelPart "foo", commaPart + , mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "HsExpanded1" 17 $ (@=?) + [defInlayHint { _position = Position 17 19 + , _label = InR [ mkLabelPart "foo" ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo}" 17 10 20 ] + , _tooltip = Just $ InL "Expand record wildcard" + }] + , mkInlayHintsTest "HsExpanded2" 23 $ (@=?) + [defInlayHint { _position = Position 23 21 + , _label = InR [ mkLabelPart "bar" ] + , _textEdits = Just [ mkLineTextEdit "YourRec {bar}" 23 10 22 ] + , _tooltip = Just $ InL "Expand record wildcard" + }] + , mkInlayHintsTest "Mixed" 14 $ (@=?) + [defInlayHint { _position = Position 14 36 + , _label = InR [ mkLabelPart "baz", commaPart + , mkLabelPart "quux" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar = bar', baz}" 14 10 37 ] + , _tooltip = Just $ InL "Expand record wildcard" + }] + , mkInlayHintsTest "Unused" 12 $ (@=?) + [defInlayHint { _position = Position 12 19 + , _label = InR [ mkLabelPart "foo", commaPart + , mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "Unused2" 12 $ (@=?) + [defInlayHint { _position = Position 12 19 + , _label = InR [ mkLabelPart "foo", commaPart + , mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "Unused2" 12 $ (@=?) + [defInlayHint { _position = Position 12 19 + , _label = InR [ mkLabelPart "foo", commaPart + , mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "WildcardOnly" 12 $ (@=?) + [defInlayHint { _position = Position 12 19 + , _label = InR [ mkLabelPart "foo", commaPart + , mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "WithExplicitBind" 12 $ (@=?) + [defInlayHint { _position = Position 12 31 + , _label = InR [ mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo = foo', bar, baz}" 12 10 32 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + }] + , mkInlayHintsTest "WithPun" 13 $ (@=?) + [defInlayHint { _position = Position 13 24 + , _label = InR [ mkLabelPart "bar", commaPart + , mkLabelPart "baz" + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 13 10 25 ] + , _tooltip = Just $ InL "Expand record wildcard" + }] + ] ] +mkInlayHintsTest :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +mkInlayHintsTest fp line assert = + testCase fp $ + runSessionWithServer def plugin testDataDir $ do + doc <- openDoc (fp ++ ".hs") "haskell" + inlayHints <- getInlayHints doc (lineRange line) + liftIO $ assert inlayHints + where + lineRange line = Range (Position line 0) (Position line 1000) + mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTestNoAction title fp x1 y1 x2 y2 = testCase title $ @@ -66,5 +174,50 @@ isExplicitFieldsCodeAction :: CodeAction -> Bool isExplicitFieldsCodeAction CodeAction {_title} = "Expand record wildcard" `T.isPrefixOf` _title +defInlayHint :: InlayHint +defInlayHint = + InlayHint + { _position = Position 0 0 + , _label = InR [] + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + +mkLabelPart :: Text -> InlayHintLabelPart +mkLabelPart value = + InlayHintLabelPart + { _location = Nothing + , _value = value + , _tooltip = Nothing + , _command = Nothing + } + +commaPart :: InlayHintLabelPart +commaPart = + InlayHintLabelPart + { _location = Nothing + , _value = ", " + , _tooltip = Nothing + , _command = Nothing + } + +mkLineTextEdit :: Text -> UInt -> UInt -> UInt -> TextEdit +mkLineTextEdit newText line x y = + TextEdit + { _range = Range (Position line x) (Position line y) + , _newText = newText + } + +mkPragmaTextEdit :: UInt -> TextEdit +mkPragmaTextEdit line = + TextEdit + { _range = Range (Position line 0) (Position line 0) + , _newText = "{-# LANGUAGE NamedFieldPuns #-}\n" + } + testDataDir :: FilePath testDataDir = "plugins" "hls-explicit-record-fields-plugin" "test" "testdata" From 9a4d7f5cd954b6e556f9a8d9398a1705b1288f42 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 16 Jul 2024 07:12:01 +0800 Subject: [PATCH 37/51] dotdot location in label part --- .../src/Ide/Plugin/ExplicitFields.hs | 217 ++++++++++-------- 1 file changed, 116 insertions(+), 101 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 00303f774b..5ec88e14cc 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -12,89 +12,97 @@ module Ide.Plugin.ExplicitFields , Log ) where -import Control.Lens ((&), (?~), (^.)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Maybe -import Data.Aeson (toJSON) -import Data.Generics (GenericQ, everything, - everythingBut, extQ, mkQ) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, mapMaybe, - maybeToList) -import Data.Text (Text) -import Data.Unique (hashUnique, newUnique) - -import Control.Monad (replicateM) -import Data.List (intersperse) -import Development.IDE (IdeState, Pretty (..), - Range (_end), Recorder (..), - Rules, WithPriority (..), - defineNoDiagnostics, - realSrcSpanToRange, - srcSpanToRange, viaShow) +import Data.Generics (GenericQ, everything, + everythingBut, extQ, mkQ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, + mapMaybe, maybeToList) +import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) + +import Control.Monad (replicateM) +import Data.Aeson (ToJSON (toJSON)) +import Data.List (intersperse) +import Development.IDE (IdeState, + Location (Location), + Pretty (..), + Range (_end), + Recorder (..), Rules, + WithPriority (..), + defineNoDiagnostics, + realSrcSpanToRange, + shakeExtras, + srcSpanToRange, viaShow) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.RuleTypes (TcModuleResult (..), - TypeCheck (..)) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpr (XExpr), - HsRecFields (..), LPat, - Outputable, getLoc, - recDotDot, unLoc) -import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, - HsExpr (RecordCon, rcon_flds), - HsRecField, LHsExpr, - LocatedA, Name, Pass (..), - Pat (..), RealSrcSpan, - UniqFM, conPatDetails, - emptyUFM, hfbPun, hfbRHS, - hs_valds, lookupUFM, - mapConPatDetail, mapLoc, - pattern RealSrcSpan, - plusUFM_C, unitUFM) -import Development.IDE.GHC.Util (getExtensions, - printOutputable) -import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData) -import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), - getFirstPragma, - insertNewPragma) -import GHC.Generics (Generic) -import Ide.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) -import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), - getNormalizedFilePathE, - handleMaybe) -import Ide.Plugin.RangeMap (RangeMap) -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) -import Ide.Types (PluginDescriptor (..), - PluginId (..), - PluginMethodHandler, - ResolveFunction, - defaultPluginDescriptor, - mkPluginHandler) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..), - SMethod (SMethod_TextDocumentInlayHint)) -import Language.LSP.Protocol.Types (CodeAction (..), - CodeActionKind (CodeActionKind_RefactorRewrite), - CodeActionParams (CodeActionParams), - Command, InlayHint (..), - InlayHintLabelPart (InlayHintLabelPart), - InlayHintParams (InlayHintParams, _range, _textDocument), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit), - isSubrangeOf, - type (|?) (InL, InR)) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsExpr (XExpr), + HsRecFields (..), LPat, + Outputable, getLoc, + recDotDot, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + HsRecField, LHsExpr, + LocatedA, Name, + Pass (..), Pat (..), + RealSrcSpan, UniqFM, + conPatDetails, emptyUFM, + hfbPun, hfbRHS, hs_valds, + lookupUFM, + mapConPatDetail, mapLoc, + pattern RealSrcSpan, + plusUFM_C, unitUFM) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), + cmapWithPrio, logWith, + (<+>)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + ResolveFunction, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..), + SMethod (SMethod_TextDocumentInlayHint)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), + CodeActionParams (CodeActionParams), + Command, InlayHint (..), + InlayHintLabelPart (InlayHintLabelPart), + InlayHintParams (InlayHintParams, _range, _textDocument), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit), + isSubrangeOf, + type (|?) (InL, InR)) + #if __GLASGOW_HASKELL__ < 910 -import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) #else -import Development.IDE.GHC.Compat (XXExprGhcRn (..)) +import Development.IDE.GHC.Compat (XXExprGhcRn (..)) #endif data Log @@ -164,35 +172,44 @@ inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do nfp <- getNormalizedFilePathE uri pragma <- getFirstPragma pId state nfp - crr@CRR{crCodeActions, crCodeActionResolve} <- runActionE "ExplicitFields.CollectRecords" state $ useE CollectRecords nfp - let records = [ record - | uid <- filterByRange' visibleRange crCodeActions - , Just record <- [IntMap.lookup uid crCodeActionResolve] - ] - in pure $ InL $ mapMaybe (mkInlayHints crr pragma) records + runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do + (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp + let records = [ record + | Just range <- [toCurrentRange pm visibleRange] + , uid <- filterByRange' range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] + ] + -- TODO: definition location? + -- locations = [ getDefinition nfp pos + -- | record <- records + -- , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record + -- ] + -- defnLocsList <- liftIO $ runIdeAction "" (shakeExtras state) (sequence locations) + pure $ InL $ mapMaybe (mkInlayHints crr pragma) records where + mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> RecordInfo -> Maybe InlayHint mkInlayHints CRR {enabledExtensions, nameMap} pragma record = - let end = fmap _end $ recordInfoToDotDotRange record -- TODO: consider position - -- TODO: consider textEdits + let range = recordInfoToDotDotRange record textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record) <> maybeToList (pragmaEdit enabledExtensions pragma) - labels = renderRecordInfoAsInlayHintLabel record + values = renderRecordInfoAsLabelValue record in do - pos <- end - lbls <- labels - let lbl = intersperse (mkInlayHintLabelPart ", ") $ fmap mkInlayHintLabelPart lbls - pure $ InlayHint { _position = pos - , _label = InR lbl + range' <- range + values' <- values + let -- valueWithLoc = zip values' (sequence defnLocs) + loc = Location uri range' + label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart (map (, Just loc) values') + pure $ InlayHint { _position = _end range' + , _label = InR label , _kind = Nothing -- neither a type nor a parameter , _textEdits = Just textEdits , _tooltip = Just $ InL (mkTitle enabledExtensions) - , _paddingLeft = Nothing + , _paddingLeft = Just True -- padding after dotdot , _paddingRight = Nothing , _data_ = Nothing } filterByRange' range = map snd . filter (flip isSubrangeOf range . fst) . RangeMap.unRangeMap - -- TODO: tooltip: display hover info, need resolve - mkInlayHintLabelPart value = InlayHintLabelPart value Nothing Nothing Nothing + mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing mkTitle :: [Extension] -> Text @@ -228,7 +245,7 @@ collectRecordsRule recorder = pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where getEnabledExtensions :: TcModuleResult -> [Extension] - getEnabledExtensions = getExtensions . tmrParsed + getEnabledExtensions = getExtensions . tmrParsed toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] @@ -313,8 +330,6 @@ recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss --- TODO: better name for those, not sure - recordInfoToDotDotRange :: RecordInfo -> Maybe Range recordInfoToDotDotRange (RecordInfoPat _ (ConPat _ _ (RecCon flds))) = srcSpanToRange . getLoc =<< rec_dotdot flds recordInfoToDotDotRange (RecordInfoCon _ (RecordCon _ _ flds)) = srcSpanToRange . getLoc =<< rec_dotdot flds @@ -324,9 +339,9 @@ renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr -renderRecordInfoAsInlayHintLabel :: RecordInfo -> Maybe [Text] -renderRecordInfoAsInlayHintLabel (RecordInfoPat _ pat) = showRecordPatFlds pat -renderRecordInfoAsInlayHintLabel (RecordInfoCon _ expr) = showRecordConFlds expr +renderRecordInfoAsLabelValue :: RecordInfo -> Maybe [Text] +renderRecordInfoAsLabelValue (RecordInfoPat _ pat) = showRecordPatFlds pat +renderRecordInfoAsLabelValue (RecordInfoCon _ expr) = showRecordConFlds expr -- | Checks if a 'Name' is referenced in the given map of names. The From f229b811168e5efc904f55327b4ca97aa6ae0a08 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 16 Jul 2024 08:10:29 +0800 Subject: [PATCH 38/51] update test for dotdot location in label part --- haskell-language-server.cabal | 1 + .../test/Main.hs | 245 ++++++++++-------- 2 files changed, 145 insertions(+), 101 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8aac08c0ab..5e22ab7f62 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1344,6 +1344,7 @@ test-suite hls-explicit-record-fields-plugin-tests , base , filepath , text + , ghcide , haskell-language-server:hls-explicit-record-fields-plugin , hls-test-utils == 2.9.0.1 diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 581d2f455b..398ce057fa 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -6,6 +6,9 @@ module Main ( main ) where import Data.Either (rights) import Data.Text (Text) import qualified Data.Text as T +import Development.IDE (filePathToUri', + toNormalizedFilePath') +import Development.IDE.Test (canonicalizeUri) import qualified Ide.Plugin.ExplicitFields as ExplicitFields import System.FilePath ((<.>), ()) import Test.Hls @@ -34,99 +37,135 @@ test = testGroup "explicit-fields" , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 ] , testGroup "inlay hints" - [ mkInlayHintsTest "Construction" 16 $ (@=?) - [defInlayHint { _position = Position 16 14 - , _label = InR [ mkLabelPart "foo", commaPart - , mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "HsExpanded1" 17 $ (@=?) - [defInlayHint { _position = Position 17 19 - , _label = InR [ mkLabelPart "foo" ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo}" 17 10 20 ] - , _tooltip = Just $ InL "Expand record wildcard" - }] - , mkInlayHintsTest "HsExpanded2" 23 $ (@=?) - [defInlayHint { _position = Position 23 21 - , _label = InR [ mkLabelPart "bar" ] - , _textEdits = Just [ mkLineTextEdit "YourRec {bar}" 23 10 22 ] - , _tooltip = Just $ InL "Expand record wildcard" - }] - , mkInlayHintsTest "Mixed" 14 $ (@=?) - [defInlayHint { _position = Position 14 36 - , _label = InR [ mkLabelPart "baz", commaPart - , mkLabelPart "quux" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar = bar', baz}" 14 10 37 ] - , _tooltip = Just $ InL "Expand record wildcard" - }] - , mkInlayHintsTest "Unused" 12 $ (@=?) - [defInlayHint { _position = Position 12 19 - , _label = InR [ mkLabelPart "foo", commaPart - , mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "Unused2" 12 $ (@=?) - [defInlayHint { _position = Position 12 19 - , _label = InR [ mkLabelPart "foo", commaPart - , mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "Unused2" 12 $ (@=?) - [defInlayHint { _position = Position 12 19 - , _label = InR [ mkLabelPart "foo", commaPart - , mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "WildcardOnly" 12 $ (@=?) - [defInlayHint { _position = Position 12 19 - , _label = InR [ mkLabelPart "foo", commaPart - , mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 12 10 20 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "WithExplicitBind" 12 $ (@=?) - [defInlayHint { _position = Position 12 31 - , _label = InR [ mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo = foo', bar, baz}" 12 10 32 - , mkPragmaTextEdit 2 - ] - , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" - }] - , mkInlayHintsTest "WithPun" 13 $ (@=?) - [defInlayHint { _position = Position 13 24 - , _label = InR [ mkLabelPart "bar", commaPart - , mkLabelPart "baz" - ] - , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 13 10 25 ] - , _tooltip = Just $ InL "Expand record wildcard" - }] + [ mkInlayHintsTest "Construction" 16 $ \ih -> do + let mkLabelPart' = mkLabelPart "Construction" 16 12 + foo <- mkLabelPart' "foo" + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 16 14 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded1" 17 $ \ih -> do + let mkLabelPart' = mkLabelPart "HsExpanded1" 17 17 + foo <- mkLabelPart' "foo" + (@?=) ih + [defInlayHint { _position = Position 17 19 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo}" 17 10 20 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded2" 23 $ \ih -> do + let mkLabelPart' = mkLabelPart "HsExpanded2" 23 19 + bar <- mkLabelPart' "bar" + (@?=) ih + [defInlayHint { _position = Position 23 21 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "YourRec {bar}" 23 10 22 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Mixed" 14 $ \ih -> do + let mkLabelPart' = mkLabelPart "Mixed" 14 34 + baz <- mkLabelPart' "baz" + quux <- mkLabelPart' "quux" + (@?=) ih + [defInlayHint { _position = Position 14 36 + , _label = InR [ baz, commaPart + , quux + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar = bar', baz}" 14 10 37 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "Unused" 12 17 + foo <- mkLabelPart' "foo" + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused2" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "Unused2" 12 17 + foo <- mkLabelPart' "foo" + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WildcardOnly" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "WildcardOnly" 12 17 + foo <- mkLabelPart' "foo" + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithExplicitBind" 12 $ \ih -> do + let mkLabelPart' = mkLabelPart "WithExplicitBind" 12 29 + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 12 31 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo = foo', bar, baz}" 12 10 32 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithPun" 13 $ \ih -> do + let mkLabelPart' = mkLabelPart "WithPun" 13 22 + bar <- mkLabelPart' "bar" + baz <- mkLabelPart' "baz" + (@?=) ih + [defInlayHint { _position = Position 13 24 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 13 10 25 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] ] ] @@ -187,14 +226,18 @@ defInlayHint = , _data_ = Nothing } -mkLabelPart :: Text -> InlayHintLabelPart -mkLabelPart value = - InlayHintLabelPart - { _location = Nothing - , _value = value - , _tooltip = Nothing - , _command = Nothing - } +mkLabelPart :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPart fp dotline dotstart value = do + uri' <- uri + pure $ InlayHintLabelPart { _location = Just (location uri' dotline dotstart) + , _value = value + , _tooltip = Nothing + , _command = Nothing + } + where + toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' + uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) + location uri line char = Location uri (Range (Position line char) (Position line (char + 2))) commaPart :: InlayHintLabelPart commaPart = From 7f8ee62d79c7caac294dc8a46b26cc1990711230 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 22 Jul 2024 01:38:54 +0800 Subject: [PATCH 39/51] get(Type)Definition with its Identifier --- ghcide/src/Development/IDE/Core/Actions.hs | 18 ++++++++++++------ ghcide/src/Development/IDE/GHC/Compat/Core.hs | 2 ++ .../Development/IDE/LSP/HoverDefinition.hs | 4 ++-- ghcide/src/Development/IDE/Spans/AtPoint.hs | 19 +++++++++++-------- 4 files changed, 27 insertions(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 4c808f21d9..51ae0ad73e 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -98,24 +98,30 @@ toCurrentLocations mapping file = mapMaybeM go nUri = toNormalizedUri uri -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' - MaybeT $ Just <$> toCurrentLocations mapping file locations + locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + MaybeT $ do + let (locations, names) = unzip locationsWithIdentifier + curLocations <- toCurrentLocations mapping file locations + pure (Just $ zip curLocations names) -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' - MaybeT $ Just <$> toCurrentLocations mapping file locations + locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + MaybeT $ do + let (locations, names) = unzip locationsWithIdentifier + curLocations <- toCurrentLocations mapping file locations + pure (Just $ zip curLocations names) highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 15ce2f4412..c6d4bc84bc 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -633,6 +633,8 @@ instance HasSrcSpan (EpAnn a) where #if MIN_VERSION_ghc(9,9,0) instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where getLoc (L l _) = getLoc l +instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where + getLoc = GHC.getHasLoc #else instance HasSrcSpan (SrcSpanAnn' ann) where getLoc = GHC.locA diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index aea3449bf3..e4c20504e4 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -47,8 +47,8 @@ gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPos hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) -gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR . map fst) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR . map fst) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 434c684b96..56c78c28c9 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -186,7 +186,7 @@ gotoTypeDefinition -> IdeOptions -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans @@ -199,7 +199,7 @@ gotoDefinition -> M.Map ModuleName NormalizedFilePath -> HieASTs a -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans @@ -314,7 +314,7 @@ typeLocationsAtPoint -> IdeOptions -> Position -> HieAstResult - -> m [Location] + -> m [(Location, Identifier)] typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = case hieKind of HieFromDisk hf -> @@ -332,12 +332,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi HQualTy a b -> getTypes' [a,b] HCastTy a -> getTypes' [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts) HieFresh -> let ts = concat $ pointCommand ast pos getts getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -361,13 +361,16 @@ locationsAtPoint -> M.Map ModuleName NormalizedFilePath -> Position -> HieASTs a - -> m [Location] + -> m [(Location, Identifier)] locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns + modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM + (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) + (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) + ns -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) From 0dd9ef3f6d3c269547a725ac9608080d257b3fcc Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 22 Jul 2024 01:46:47 +0800 Subject: [PATCH 40/51] add flipped filterByRange --- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 7b1887a802..67324833a5 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -13,6 +13,7 @@ module Ide.Plugin.RangeMap fromList, fromList', filterByRange, + flippedFilterByRange, ) where import Development.IDE.Graph.Classes (NFData) @@ -67,6 +68,14 @@ filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeM filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap #endif +-- | Flipped filter a 'RangeMap' by a given 'Range'. +flippedFilterByRange :: Range -> RangeMap a -> [a] +#ifdef USE_FINGERTREE +flippedFilterByRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap +#else +flippedFilterByRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap +#endif + #ifdef USE_FINGERTREE -- NOTE(ozkutuk): In itself, this conversion is wrong. As Michael put it: -- "LSP Ranges have exclusive upper bounds, whereas the intervals here are From 1810a670ff9f1e1d2b2c67d003aa40ade3a5b8f2 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 22 Jul 2024 01:47:27 +0800 Subject: [PATCH 41/51] filter label with name --- ghcide/src/Development/IDE/GHC/Orphans.hs | 6 + .../src/Ide/Plugin/ExplicitFields.hs | 128 +++++++++--------- 2 files changed, 72 insertions(+), 62 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 3572662356..8d46d44445 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -226,6 +226,12 @@ instance NFData (HsExpr (GhcPass Renamed)) where instance NFData (Pat (GhcPass Renamed)) where rnf = rwhnf +instance NFData (HsExpr (GhcPass Typechecked)) where + rnf = rwhnf + +instance NFData (Pat (GhcPass Typechecked)) where + rnf = rwhnf + instance NFData Extension where rnf = rwhnf diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 5ec88e14cc..968804efa2 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -26,14 +26,16 @@ import Data.Unique (hashUnique, newUnique) import Control.Monad (replicateM) import Data.Aeson (ToJSON (toJSON)) -import Data.List (intersperse) +import Data.List (find, intersperse) +import qualified Data.Text as T import Development.IDE (IdeState, Location (Location), Pretty (..), - Range (_end), + Range (Range, _end, _start), Recorder (..), Rules, WithPriority (..), defineNoDiagnostics, + getDefinition, printName, realSrcSpanToRange, shakeExtras, srcSpanToRange, viaShow) @@ -42,20 +44,27 @@ import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpr (XExpr), - HsRecFields (..), LPat, - Outputable, getLoc, +import Development.IDE.GHC.Compat (FieldOcc (FieldOcc), + GhcPass, GhcTc, + HasSrcSpan (getLoc), + HsConDetails (RecCon), + HsExpr (HsVar, XExpr), + HsFieldBind (hfbLHS), + HsRecFields (..), + Identifier, LPat, + NamedThing (getName), + Outputable, + TcGblEnv (tcg_binds), + Var (varName), + XXExprGhcTc (..), recDotDot, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, HsExpr (RecordCon, rcon_flds), HsRecField, LHsExpr, - LocatedA, Name, - Pass (..), Pat (..), + LocatedA, Name, Pat (..), RealSrcSpan, UniqFM, conPatDetails, emptyUFM, - hfbPun, hfbRHS, hs_valds, + hfbPun, hfbRHS, lookupUFM, mapConPatDetail, mapLoc, pattern RealSrcSpan, @@ -95,14 +104,11 @@ import Language.LSP.Protocol.Types (CodeAction (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), - isSubrangeOf, type (|?) (InL, InR)) #if __GLASGOW_HASKELL__ < 910 import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) -#else -import Development.IDE.GHC.Compat (XXExprGhcRn (..)) #endif data Log @@ -174,44 +180,45 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent pragma <- getFirstPragma pId state nfp runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp - let records = [ record + let -- Get all records with dotdot in current nfp + records = [ record | Just range <- [toCurrentRange pm visibleRange] - , uid <- filterByRange' range crCodeActions - , Just record <- [IntMap.lookup uid crCodeActionResolve] - ] - -- TODO: definition location? - -- locations = [ getDefinition nfp pos - -- | record <- records - -- , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record - -- ] - -- defnLocsList <- liftIO $ runIdeAction "" (shakeExtras state) (sequence locations) - pure $ InL $ mapMaybe (mkInlayHints crr pragma) records + , uid <- RangeMap.flippedFilterByRange range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] ] + -- Get the definition of each dotdot of record + locations = [ getDefinition nfp pos + | record <- records + , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ] + defnLocsList <- liftIO $ Shake.runIdeAction "ExplicitFields.getDefinition" (shakeExtras state) (sequence locations) + pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records) where - mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> RecordInfo -> Maybe InlayHint - mkInlayHints CRR {enabledExtensions, nameMap} pragma record = + mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint + mkInlayHints CRR {enabledExtensions, nameMap} pragma (defnLocs, record) = let range = recordInfoToDotDotRange record textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record) <> maybeToList (pragmaEdit enabledExtensions pragma) - values = renderRecordInfoAsLabelValue record + names = renderRecordInfoAsLabelName record in do - range' <- range - values' <- values - let -- valueWithLoc = zip values' (sequence defnLocs) - loc = Location uri range' - label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart (map (, Just loc) values') - pure $ InlayHint { _position = _end range' + end <- fmap _end range + names' <- names + defnLocs' <- defnLocs + let excludeDotDot (Location _ (Range _ pos)) = pos /= end + -- find location from dotdot definitions that name equal to label name + findLocation t = fmap fst . find (either (const False) ((==) t) . snd) . filter (excludeDotDot . fst) + valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ] + -- use `, ` to separate labels with definition location + label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc + pure $ InlayHint { _position = end -- at the end of dotdot , _label = InR label , _kind = Nothing -- neither a type nor a parameter - , _textEdits = Just textEdits - , _tooltip = Just $ InL (mkTitle enabledExtensions) + , _textEdits = Just textEdits -- same as CodeAction + , _tooltip = Just $ InL (mkTitle enabledExtensions) -- same as CodeAction , _paddingLeft = Just True -- padding after dotdot , _paddingRight = Nothing , _data_ = Nothing } - filterByRange' range = map snd . filter (flip isSubrangeOf range . fst) . RangeMap.unRangeMap mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing - mkTitle :: [Extension] -> Text mkTitle exts = "Expand record wildcard" <> if NamedFieldPuns `elem` exts @@ -249,11 +256,7 @@ collectRecordsRule recorder = toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] -#if __GLASGOW_HASKELL__ < 910 -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds -#else -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds -#endif +getRecords (tcg_binds . tmrTypechecked -> valBinds) = collectRecords valBinds collectNamesRule :: Rules () collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do @@ -318,8 +321,8 @@ instance Show CollectNamesResult where type instance RuleResult CollectNames = CollectNamesResult data RecordInfo - = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) - | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + = RecordInfoPat RealSrcSpan (Pat GhcTc) + | RecordInfoCon RealSrcSpan (HsExpr GhcTc) deriving (Generic) instance Pretty RecordInfo where @@ -339,9 +342,9 @@ renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr -renderRecordInfoAsLabelValue :: RecordInfo -> Maybe [Text] -renderRecordInfoAsLabelValue (RecordInfoPat _ pat) = showRecordPatFlds pat -renderRecordInfoAsLabelValue (RecordInfoCon _ expr) = showRecordConFlds expr +renderRecordInfoAsLabelName :: RecordInfo -> Maybe [Name] +renderRecordInfoAsLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat +renderRecordInfoAsLabelName (RecordInfoCon _ expr) = showRecordConFlds expr -- | Checks if a 'Name' is referenced in the given map of names. The @@ -362,11 +365,11 @@ filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) preprocessRecordPat - :: p ~ GhcPass 'Renamed + :: p ~ GhcTc => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) -preprocessRecordPat = preprocessRecord (getFieldName . unLoc) +preprocessRecordPat = preprocessRecord (fmap varName . getFieldName . unLoc) where getFieldName x = case unLoc (hfbRHS x) of VarPat _ x' -> Just $ unLoc x' _ -> Nothing @@ -427,13 +430,13 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' } puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) -showRecordPatFlds :: Pat (GhcPass 'Renamed) -> Maybe [Text] -showRecordPatFlds (ConPat _ _ args) = fmap (fmap printOutputable . rec_flds) (m args) +showRecordPatFlds :: Pat GhcTc -> Maybe [Name] +showRecordPatFlds (ConPat _ _ args) = fmap (fmap ((\case FieldOcc x _ -> getName x) . unLoc . hfbLHS . unLoc) . rec_flds) (m args) where m (RecCon flds) = Just $ processRecordFlds flds m _ = Nothing @@ -445,8 +448,11 @@ showRecordCon expr@(RecordCon _ _ flds) = expr { rcon_flds = preprocessRecordCon flds } showRecordCon _ = Nothing -showRecordConFlds :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe [Text] -showRecordConFlds (RecordCon _ _ flds) = Just $ fmap printOutputable (rec_flds $ processRecordFlds flds) +showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name] +showRecordConFlds (RecordCon _ _ flds) = mapM (m . unLoc . hfbRHS . unLoc) (rec_flds $ processRecordFlds flds) + where + m (HsVar _ lidp) = Just $ getName lidp + m _ = Nothing showRecordConFlds _ = Nothing @@ -466,7 +472,7 @@ collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` get collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) -getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- When we stumble upon an occurrence of HsExpanded, we only want to follow a -- single branch. We do this here, by explicitly returning occurrences from -- traversing the original branch, and returning True, which keeps syb from @@ -475,25 +481,23 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- branch #if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, True) #else -getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) #endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LHsExpr GhcTc -> [RecordInfo] mkRecInfo expr = [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] getRecCons _ = ([], False) -getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool) getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) where - mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LPat GhcTc -> [RecordInfo] mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = ([], False) - - From a4103bd64b2a914e32c94d3f9696eec7d84f496d Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 22 Jul 2024 01:47:44 +0800 Subject: [PATCH 42/51] update test --- .../test/Main.hs | 64 +++++++++---------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 398ce057fa..fdfbe4528c 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -38,10 +38,10 @@ test = testGroup "explicit-fields" ] , testGroup "inlay hints" [ mkInlayHintsTest "Construction" 16 $ \ih -> do - let mkLabelPart' = mkLabelPart "Construction" 16 12 - foo <- mkLabelPart' "foo" - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "Construction" + foo <- mkLabelPart' 13 6 "foo" + bar <- mkLabelPart' 14 6 "bar" + baz <- mkLabelPart' 15 6 "baz" (@?=) ih [defInlayHint { _position = Position 16 14 , _label = InR [ foo, commaPart @@ -55,8 +55,8 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "HsExpanded1" 17 $ \ih -> do - let mkLabelPart' = mkLabelPart "HsExpanded1" 17 17 - foo <- mkLabelPart' "foo" + let mkLabelPart' = mkLabelPart "HsExpanded1" + foo <- mkLabelPart' 11 4 "foo" (@?=) ih [defInlayHint { _position = Position 17 19 , _label = InR [ foo ] @@ -65,8 +65,8 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "HsExpanded2" 23 $ \ih -> do - let mkLabelPart' = mkLabelPart "HsExpanded2" 23 19 - bar <- mkLabelPart' "bar" + let mkLabelPart' = mkLabelPart "HsExpanded2" + bar <- mkLabelPart' 14 4 "bar" (@?=) ih [defInlayHint { _position = Position 23 21 , _label = InR [ bar ] @@ -75,9 +75,9 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "Mixed" 14 $ \ih -> do - let mkLabelPart' = mkLabelPart "Mixed" 14 34 - baz <- mkLabelPart' "baz" - quux <- mkLabelPart' "quux" + let mkLabelPart' = mkLabelPart "Mixed" + baz <- mkLabelPart' 9 4 "baz" + quux <- mkLabelPart' 10 4 "quux" (@?=) ih [defInlayHint { _position = Position 14 36 , _label = InR [ baz, commaPart @@ -88,10 +88,10 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "Unused" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "Unused" 12 17 - foo <- mkLabelPart' "foo" - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "Unused" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" (@?=) ih [defInlayHint { _position = Position 12 19 , _label = InR [ foo, commaPart @@ -105,10 +105,10 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "Unused2" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "Unused2" 12 17 - foo <- mkLabelPart' "foo" - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "Unused2" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" (@?=) ih [defInlayHint { _position = Position 12 19 , _label = InR [ foo, commaPart @@ -122,10 +122,10 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "WildcardOnly" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "WildcardOnly" 12 17 - foo <- mkLabelPart' "foo" - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "WildcardOnly" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" (@?=) ih [defInlayHint { _position = Position 12 19 , _label = InR [ foo, commaPart @@ -139,9 +139,9 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "WithExplicitBind" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "WithExplicitBind" 12 29 - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "WithExplicitBind" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" (@?=) ih [defInlayHint { _position = Position 12 31 , _label = InR [ bar, commaPart @@ -154,9 +154,9 @@ test = testGroup "explicit-fields" , _paddingLeft = Just True }] , mkInlayHintsTest "WithPun" 13 $ \ih -> do - let mkLabelPart' = mkLabelPart "WithPun" 13 22 - bar <- mkLabelPart' "bar" - baz <- mkLabelPart' "baz" + let mkLabelPart' = mkLabelPart "WithPun" + bar <- mkLabelPart' 8 4 "bar" + baz <- mkLabelPart' 9 4 "baz" (@?=) ih [defInlayHint { _position = Position 13 24 , _label = InR [ bar, commaPart @@ -227,9 +227,9 @@ defInlayHint = } mkLabelPart :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart -mkLabelPart fp dotline dotstart value = do +mkLabelPart fp line start value = do uri' <- uri - pure $ InlayHintLabelPart { _location = Just (location uri' dotline dotstart) + pure $ InlayHintLabelPart { _location = Just (location uri' line start) , _value = value , _tooltip = Nothing , _command = Nothing @@ -237,7 +237,7 @@ mkLabelPart fp dotline dotstart value = do where toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) - location uri line char = Location uri (Range (Position line char) (Position line (char + 2))) + location uri line char = Location uri (Range (Position line char) (Position line (char + (fromIntegral $ T.length value)))) commaPart :: InlayHintLabelPart commaPart = From 931ae0e65a7090df5bd6adf9af403d172c02ae3a Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 10 Aug 2024 13:23:32 +0800 Subject: [PATCH 43/51] re-generate schema --- test/testdata/schema/ghc94/default-config.golden.json | 3 ++- .../schema/ghc94/vscode-extension-schema.golden.json | 10 ++++++++-- test/testdata/schema/ghc96/default-config.golden.json | 3 ++- .../schema/ghc96/vscode-extension-schema.golden.json | 10 ++++++++-- test/testdata/schema/ghc98/default-config.golden.json | 3 ++- .../schema/ghc98/vscode-extension-schema.golden.json | 10 ++++++++-- 6 files changed, 30 insertions(+), 9 deletions(-) diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 5f881ff00e..aa9c70aaf9 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -42,7 +42,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 5da4a27dd6..b70c510c84 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -83,9 +83,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 5f881ff00e..aa9c70aaf9 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -42,7 +42,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 5da4a27dd6..b70c510c84 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -83,9 +83,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 5f881ff00e..aa9c70aaf9 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -42,7 +42,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 5da4a27dd6..b70c510c84 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -83,9 +83,15 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", "scope": "resource", "type": "boolean" }, From 9ba894b150a3dc9ebe45aa07d8ec16d56b244d8f Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 21:20:36 +0800 Subject: [PATCH 44/51] fix explict-record-fields plugin in GHC 910 --- .../src/Ide/Plugin/ExplicitFields.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 968804efa2..5cde3e08de 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -481,7 +481,7 @@ getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- branch #if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) #else getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) #endif From 1c2e3b7bdbff6be2f19862ba655522e9559fa809 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 22:11:24 +0800 Subject: [PATCH 45/51] fix use correct currentPosition --- ghcide/src/Development/IDE/Core/Actions.hs | 67 +++++++++++----------- 1 file changed, 32 insertions(+), 35 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 51ae0ad73e..20c86c8280 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -66,36 +66,32 @@ getAtPoint file pos = runMaybeT $ do !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Location, determine if we have the PositionMapping --- for the correct file. If not, get the correct position mapping --- and then apply the position mapping to the location. -toCurrentLocations +-- | Converts locations in the source code to their current positions, +-- taking into account changes that may have occurred due to edits. +toCurrentLocation :: PositionMapping -> NormalizedFilePath - -> [Location] - -> IdeAction [Location] -toCurrentLocations mapping file = mapMaybeM go + -> Location + -> IdeAction (Maybe Location) +toCurrentLocation mapping file (Location uri range) = + -- The Location we are going to might be in a different + -- file than the one we are calling gotoDefinition from. + -- So we check that the location file matches the file + -- we are in. + if nUri == normalizedFilePathToUri file + -- The Location matches the file, so use the PositionMapping + -- we have. + then pure $ Location uri <$> toCurrentRange mapping range + -- The Location does not match the file, so get the correct + -- PositionMapping and use that instead. + else do + otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do + otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri + useWithStaleFastMT GetHieAst otherLocationFile + pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) where - go :: Location -> IdeAction (Maybe Location) - go (Location uri range) = - -- The Location we are going to might be in a different - -- file than the one we are calling gotoDefinition from. - -- So we check that the location file matches the file - -- we are in. - if nUri == normalizedFilePathToUri file - -- The Location matches the file, so use the PositionMapping - -- we have. - then pure $ Location uri <$> toCurrentRange mapping range - -- The Location does not match the file, so get the correct - -- PositionMapping and use that instead. - else do - otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do - otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri - useWithStaleFastMT GetHieAst otherLocationFile - pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) - where - nUri :: NormalizedUri - nUri = toNormalizedUri uri + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) @@ -106,10 +102,11 @@ getDefinition file pos = runMaybeT $ do (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' - MaybeT $ do - let (locations, names) = unzip locationsWithIdentifier - curLocations <- toCurrentLocations mapping file locations - pure (Just $ zip curLocations names) + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier + getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do @@ -118,10 +115,10 @@ getTypeDefinition file pos = runMaybeT $ do (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' - MaybeT $ do - let (locations, names) = unzip locationsWithIdentifier - curLocations <- toCurrentLocations mapping file locations - pure (Just $ zip curLocations names) + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do From a0a35b74086ca9e6c4b47867439fe641bf5a5e79 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 23:00:41 +0800 Subject: [PATCH 46/51] comment --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 56c78c28c9..88c6570b23 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -179,6 +179,7 @@ documentHighlight hf rf pos = pure highlights then DocumentHighlightKind_Write else DocumentHighlightKind_Read +-- | Locate the type definition of the name at a given position. gotoTypeDefinition :: MonadIO m => WithHieDb @@ -306,6 +307,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" +-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint :: forall m . MonadIO m @@ -352,6 +354,7 @@ namesInType _ = [] getTypes :: [Type] -> [Name] getTypes ts = concatMap namesInType ts +-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint :: forall m a . MonadIO m From 4faf1d05d0f1d7f1648da28b41da40abaacd0816 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 23:08:50 +0800 Subject: [PATCH 47/51] rename flippedFilterByRange to elementsInRange --- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 10 +++++----- .../src/Ide/Plugin/ExplicitFields.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 67324833a5..6c4b4041c9 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -13,7 +13,7 @@ module Ide.Plugin.RangeMap fromList, fromList', filterByRange, - flippedFilterByRange, + elementsInRange, ) where import Development.IDE.Graph.Classes (NFData) @@ -68,12 +68,12 @@ filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeM filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap #endif --- | Flipped filter a 'RangeMap' by a given 'Range'. -flippedFilterByRange :: Range -> RangeMap a -> [a] +-- | Extracts all elements from a 'RangeMap' that fall within a given 'Range'. +elementsInRange :: Range -> RangeMap a -> [a] #ifdef USE_FINGERTREE -flippedFilterByRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap +elementsInRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap #else -flippedFilterByRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap +elementsInRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap #endif #ifdef USE_FINGERTREE diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 5cde3e08de..ce1e863408 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -183,7 +183,7 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent let -- Get all records with dotdot in current nfp records = [ record | Just range <- [toCurrentRange pm visibleRange] - , uid <- RangeMap.flippedFilterByRange range crCodeActions + , uid <- RangeMap.elementsInRange range crCodeActions , Just record <- [IntMap.lookup uid crCodeActionResolve] ] -- Get the definition of each dotdot of record locations = [ getDefinition nfp pos From 6967f6761086b27eac80c3c3a1481cd9fd6511d0 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 23:34:28 +0800 Subject: [PATCH 48/51] refactor: lift --- .../src/Ide/Plugin/ExplicitFields.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index ce1e863408..bab1dd5ad1 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -25,6 +25,7 @@ import Data.Text (Text) import Data.Unique (hashUnique, newUnique) import Control.Monad (replicateM) +import Control.Monad.Trans.Except (except) import Data.Aeson (ToJSON (toJSON)) import Data.List (find, intersperse) import qualified Data.Text as T @@ -106,8 +107,8 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) - #if __GLASGOW_HASKELL__ < 910 +import Control.Monad.Trans.Class (lift) import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) #endif @@ -189,7 +190,7 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent locations = [ getDefinition nfp pos | record <- records , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ] - defnLocsList <- liftIO $ Shake.runIdeAction "ExplicitFields.getDefinition" (shakeExtras state) (sequence locations) + defnLocsList <- lift $ sequence locations pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records) where mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint From 7bc5843683a12f5f7889b5baf379939ec72a03ee Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 21 Aug 2024 23:53:51 +0800 Subject: [PATCH 49/51] refactor: break pointfree --- .../src/Ide/Plugin/ExplicitFields.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index bab1dd5ad1..c98cf2f5f9 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -25,7 +25,7 @@ import Data.Text (Text) import Data.Unique (hashUnique, newUnique) import Control.Monad (replicateM) -import Control.Monad.Trans.Except (except) +import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON (toJSON)) import Data.List (find, intersperse) import qualified Data.Text as T @@ -108,7 +108,6 @@ import Language.LSP.Protocol.Types (CodeAction (..), type (|?) (InL, InR)) #if __GLASGOW_HASKELL__ < 910 -import Control.Monad.Trans.Class (lift) import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) #endif @@ -203,9 +202,14 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent end <- fmap _end range names' <- names defnLocs' <- defnLocs - let excludeDotDot (Location _ (Range _ pos)) = pos /= end + let excludeDotDot (Location _ (Range _ end')) = end' /= end -- find location from dotdot definitions that name equal to label name - findLocation t = fmap fst . find (either (const False) ((==) t) . snd) . filter (excludeDotDot . fst) + findLocation name locations = + let -- filter locations not within dotdot range + filteredLocations = filter (excludeDotDot . fst) locations + -- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False' + nameEq = either (const False) ((==) name) + in fmap fst $ find (nameEq . snd) filteredLocations valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ] -- use `, ` to separate labels with definition location label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc From ab3f84aaecbb638c3a86a029843a53c974fc42f3 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 22 Aug 2024 00:31:06 +0800 Subject: [PATCH 50/51] refactor --- .../src/Ide/Plugin/ExplicitFields.hs | 40 +++++++++++-------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index c98cf2f5f9..d730132812 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -107,9 +107,9 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) -#if __GLASGOW_HASKELL__ < 910 + import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) -#endif + data Log = LogShake Shake.Log @@ -271,11 +271,11 @@ collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. getNames :: TcModuleResult -> UniqFM Name [Name] -#if __GLASGOW_HASKELL__ < 910 + getNames (tmrRenamed -> (group,_,_,_)) = collectNames group -#else -getNames (tmrRenamed -> (group,_,_,_,_)) = collectNames group -#endif + + + data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -441,10 +441,16 @@ showRecordPat names = fmap printOutputable . mapConPatDetail (\case _ -> Nothing) showRecordPatFlds :: Pat GhcTc -> Maybe [Name] -showRecordPatFlds (ConPat _ _ args) = fmap (fmap ((\case FieldOcc x _ -> getName x) . unLoc . hfbLHS . unLoc) . rec_flds) (m args) +showRecordPatFlds (ConPat _ _ args) = do + fields <- processRecCon args + names <- mapM getFieldName (rec_flds fields) + pure names where - m (RecCon flds) = Just $ processRecordFlds flds - m _ = Nothing + processRecCon (RecCon flds) = Just $ processRecordFlds flds + processRecCon _ = Nothing + getOccName (FieldOcc x _) = Just $ getName x + getOccName _ = Nothing + getFieldName = getOccName . unLoc . hfbLHS . unLoc showRecordPatFlds _ = Nothing showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text @@ -454,10 +460,12 @@ showRecordCon expr@(RecordCon _ _ flds) = showRecordCon _ = Nothing showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name] -showRecordConFlds (RecordCon _ _ flds) = mapM (m . unLoc . hfbRHS . unLoc) (rec_flds $ processRecordFlds flds) +showRecordConFlds (RecordCon _ _ flds) = + mapM getFieldName (rec_flds $ processRecordFlds flds) where - m (HsVar _ lidp) = Just $ getName lidp - m _ = Nothing + getVarName (HsVar _ lidp) = Just $ getName lidp + getVarName _ = Nothing + getFieldName = getVarName . unLoc . hfbRHS . unLoc showRecordConFlds _ = Nothing @@ -485,11 +493,11 @@ getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch -#if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) -#else + + + getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) -#endif + getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where From d78654930f857036aa10e12f45ade7edde618379 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 22 Aug 2024 00:47:42 +0800 Subject: [PATCH 51/51] recover accidentally deleted macros --- .../src/Ide/Plugin/ExplicitFields.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index d730132812..2ac8f8a692 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -107,9 +107,9 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) - +#if __GLASGOW_HASKELL__ < 910 import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) - +#endif data Log = LogShake Shake.Log @@ -271,11 +271,11 @@ collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. getNames :: TcModuleResult -> UniqFM Name [Name] - +#if __GLASGOW_HASKELL__ < 910 getNames (tmrRenamed -> (group,_,_,_)) = collectNames group - - - +#else +getNames (tmrRenamed -> (group,_,_,_,_)) = collectNames group +#endif data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -493,11 +493,11 @@ getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch - - - +#if __GLASGOW_HASKELL__ >= 910 +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) +#else getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) - +#endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where