diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 6e21a129dc..46c1a43d1a 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -106,8 +106,8 @@ import GHC (AddEpAnn (Ad DeltaPos (..), EpAnn (..), EpaLocation (..), - hsmodAnn, - LEpaComment) + LEpaComment, + hsmodAnn) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -150,6 +150,7 @@ iePluginDescriptor recorder plId = , wrap suggestNewOrExtendImportForClassMethod , wrap suggestHideShadow , wrap suggestNewImport + , wrap suggestAddRecordFieldImport ] plId in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction } @@ -1211,6 +1212,25 @@ suggestFixConstructorImport Diagnostic{_range=_range,..} in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] | otherwise = [] +suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..} + | Just fieldName <- findMissingField _message + , Just (range, indent) <- newImportInsertRange ps fileContents + = let qis = qualifiedImportStyle df + suggestions = nubSortBy simpleCompareImportSuggestion (constructNewImportSuggestions exportsMap (Nothing, NotInScopeThing fieldName) Nothing qis) + in map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions + | otherwise = [] + where + findMissingField :: T.Text -> Maybe T.Text + findMissingField t = + let + hasfieldRegex = "((.+\\.)?HasField) \"(.+)\" ([^ ]+) ([^ ]+)" + regex = "(No instance for|Could not deduce):? (\\(" <> hasfieldRegex <> "\\)|‘" <> hasfieldRegex <> "’|" <> hasfieldRegex <> ")" + match = filter (/="") <$> matchRegexUnifySpaces t regex + in case match of + Just [_, _, _, _, fieldName, _, _] -> Just fieldName + _ -> Nothing + -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} @@ -1608,10 +1628,11 @@ findPositionAfterModuleName ps hsmodName' = do epaLocationToLine :: EpaLocation -> Maybe Int #if MIN_VERSION_ghc(9,5,0) epaLocationToLine (EpaSpan sp _) + = Just . srcLocLine . realSrcSpanEnd $ sp #else epaLocationToLine (EpaSpan sp) -#endif = Just . srcLocLine . realSrcSpanEnd $ sp +#endif epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments -- 'priorComments' contains the comments right before the current EpaLocation -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and @@ -1852,16 +1873,21 @@ textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCo -- | Returns the ranges for a binding in an import declaration rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -rangesForBindingImport ImportDecl{ #if MIN_VERSION_ghc(9,5,0) +rangesForBindingImport ImportDecl{ ideclImportList = Just (Exactly, L _ lies) + } b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies + where + b' = wrapOperatorInParens b #else +rangesForBindingImport ImportDecl{ ideclHiding = Just (False, L _ lies) -#endif } b = concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies where b' = wrapOperatorInParens b +#endif rangesForBindingImport _ _ = [] wrapOperatorInParens :: String -> String diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 2200d29b3c..32720edf1e 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -310,6 +310,7 @@ codeActionTests = testGroup "code actions" , removeImportTests , suggestImportClassMethodTests , suggestImportTests + , suggestAddRecordFieldImportTests , suggestHideShadowTests , fixConstructorImportTests , fixModuleImportTypoTests @@ -1730,6 +1731,32 @@ suggestImportTests = testGroup "suggest import actions" else liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] +suggestAddRecordFieldImportTests :: TestTree +suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" + [ testGroup "The field is suggested when an instance resolution failure occurs" + [ ignoreFor (BrokenForGHC [GHC810, GHC90, GHC94, GHC96]) "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest + ] + ] + where + theTest = testSessionWithExtraFiles "hover" def $ \dir -> do + configureCheckProject False + let before = T.unlines $ "module A where" : ["import B (Foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"] + after = T.unlines $ "module A where" : ["import B (Foo, foo)", "getFoo :: Foo -> Int", "getFoo x = x.foo"] + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, B]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["module B where", "data Foo = Foo { foo :: Int }"] + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _ <- waitForDiagnostics + let defLine = fromIntegral $ 1 + 2 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + action <- liftIO $ pickActionWithTitle "Add foo to the import list of B" actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + + suggestImportDisambiguationTests :: TestTree suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" [ testGroup "Hiding strategy works"