Add an assist for importing record fields when using OverloadedRecord…

…Dot (#3642)

* Add an assist for OverloadedRecordDot

* Add a test

---------

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

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

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"