Import suggestion for missing newtype constructor, all types constructor and indirect overloadedrecorddot fields

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -12,7 +12,9 @@ module Development.IDE.Plugin.CodeAction
     fillHolePluginDescriptor,
     extendImportPluginDescriptor,
     -- * For testing
-    matchRegExMultipleImports
+    matchRegExMultipleImports,
+    extractNotInScopeName,
+    NotInScope(..)
     ) where
 
 import           Control.Applicative                               ((<|>))
@@ -1572,13 +1574,34 @@ extractQualifiedModuleNameFromMissingName (T.strip -> missing)
         modNameP = fmap snd $ RE.withMatched $ conIDP `sepBy1` RE.sym '.'
 
 
+-- | A Backward compatible implementation of `lookupOccEnv_AllNameSpaces` for
+-- GHC <=9.6
+--
+-- It looks for a symbol name in all known namespaces, including types,
+-- variables, and fieldnames.
+--
+-- Note that on GHC >= 9.8, the record selectors are not in the `mkVarOrDataOcc`
+-- anymore, but are in a custom namespace, see
+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.8#new-namespace-for-record-fields,
+-- hence we need to use this "AllNamespaces" implementation, otherwise we'll
+-- miss them.
+lookupOccEnvAllNamespaces :: ExportsMap -> T.Text -> [IdentInfo]
+#if MIN_VERSION_ghc(9,7,0)
+lookupOccEnvAllNamespaces exportsMap name = Set.toList $ mconcat (lookupOccEnv_AllNameSpaces (getExportsMap exportsMap) (mkTypeOcc name))
+#else
+lookupOccEnvAllNamespaces exportsMap name = maybe [] Set.toList $
+                            lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)
+                          <> lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name) -- look up the modified unknown name in the export map
+#endif
+
+
 constructNewImportSuggestions
   :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion]
 constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion
   [ suggestion
   | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name
-  , identInfo <- maybe [] Set.toList $ lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)
-                                    <> lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name) -- look up the modified unknown name in the export map
+
+  , identInfo <- lookupOccEnvAllNamespaces exportsMap name -- look up the modified unknown name in the export map
   , canUseIdent thingMissing identInfo                                              -- check if the identifier information retrieved can be used
   , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules                 -- check if the module of the identifier is allowed
   , suggestion <- renderNewImport identInfo                                         -- creates a list of import suggestions for the retrieved identifier information
@@ -1825,7 +1848,7 @@ data NotInScope
     = NotInScopeDataConstructor T.Text
     | NotInScopeTypeConstructorOrClass T.Text
     | NotInScopeThing T.Text
-    deriving Show
+    deriving (Show, Eq)
 
 notInScope :: NotInScope -> T.Text
 notInScope (NotInScopeDataConstructor t)        = t
@@ -1840,6 +1863,38 @@ extractNotInScopeName x
   = Just $ NotInScopeDataConstructor name
   | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
   = Just $ NotInScopeTypeConstructorOrClass name
+  | Just [name] <- matchRegexUnifySpaces x "The data constructors of ‘([^ ]+)’ are not all in scope"
+  = Just $ NotInScopeDataConstructor name
+  | Just [name] <- matchRegexUnifySpaces x "of newtype ‘([^’]*)’ is not in scope"
+  = Just $ NotInScopeThing name
+  -- Match for HasField "foo" Bar String in the context where, e.g. x.foo is
+  -- used, and x :: Bar.
+  --
+  -- This usually mean that the field is not in scope and the correct fix is to
+  -- import (Bar(foo)) or (Bar(..)).
+  --
+  -- However, it is more reliable to match for the type name instead of the field
+  -- name, and most of the time you'll want to import the complete type with all
+  -- their fields instead of the specific field.
+  --
+  -- The regex is convoluted because it accounts for:
+  --
+  -- - Qualified (or not) `HasField`
+  -- - The type bar is always qualified. If it is unqualified, it means that the
+  -- parent module is already imported, and in this context it uses an hint
+  -- already available in the GHC error message. However this regex accounts for
+  -- qualified or not, it does not cost much and should be more robust if the
+  -- hint changes in the future
+  -- - Next regex will account for polymorphic types, which appears as `HasField
+  -- "foo" (Bar Int)...`, e.g. see the parenthesis
+  | Just [_module, name] <- matchRegexUnifySpaces x "No instance for [‘(].*HasField \"[^\"]+\" ([^ (.]+\\.)*([^ (.]+).*[’)]"
+  = Just $ NotInScopeThing name
+  | Just [_module, name] <- matchRegexUnifySpaces x "No instance for [‘(].*HasField \"[^\"]+\" \\(([^ .]+\\.)*([^ .]+)[^)]*\\).*[’)]"
+  = Just $ NotInScopeThing name
+  -- The order of the "Not in scope" is important, for example, some of the
+  -- matcher may catch the "record" value instead of the value later.
+  | Just [name] <- matchRegexUnifySpaces x "Not in scope: record field ‘([^’]*)’"
+  = Just $ NotInScopeThing name
   | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"
   = Just $ NotInScopeThing name
   | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs

@@ -21,6 +21,9 @@ matchRegex message regex = case message =~~ regex of
     Nothing                                                -> Nothing
 
 -- | 'matchRegex' combined with 'unifySpaces'
+--
+-- >>> matchRegexUnifySpaces  "hello I'm a cow" "he(ll)o"
+-- Just ["ll"]
 matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
 matchRegexUnifySpaces message = matchRegex (unifySpaces message)
 

plugins/hls-refactor-plugin/test/Main.hs

@@ -46,6 +46,7 @@ import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImp
 import           Test.Hls
 
 import qualified Development.IDE.GHC.ExactPrint
+import           Development.IDE.Plugin.CodeAction        (NotInScope (..))
 import qualified Development.IDE.Plugin.CodeAction        as Refactor
 import qualified Test.AddArgument
 
@@ -68,6 +69,7 @@ tests =
   , codeActionTests
   , codeActionHelperFunctionTests
   , completionTests
+  , extractNotInScopeNameTests
   ]
 
 initializeTests :: TestTree
@@ -300,6 +302,8 @@ codeActionTests = testGroup "code actions"
   , suggestImportClassMethodTests
   , suggestImportTests
   , suggestAddRecordFieldImportTests
+  , suggestAddCoerceMissingConstructorImportTests
+  , suggestAddGenericMissingConstructorImportTests
   , suggestHideShadowTests
   , fixConstructorImportTests
   , fixModuleImportTypoTests
@@ -316,6 +320,7 @@ codeActionTests = testGroup "code actions"
   , addImplicitParamsConstraintTests
   , removeExportTests
   , Test.AddArgument.tests
+  , suggestAddRecordFieldUpdateImportTests
   ]
 
 insertImportTests :: TestTree
@@ -1849,8 +1854,14 @@ suggestImportTests = testGroup "suggest import actions"
 suggestAddRecordFieldImportTests :: TestTree
 suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot"
   [ testGroup "The field is suggested when an instance resolution failure occurs"
-    [ ignoreForGhcVersions [GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest
+    ([ ignoreForGhcVersions [GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest
     ]
+    ++ [
+        theTestIndirect qualifiedGhcRecords polymorphicType
+        |
+        qualifiedGhcRecords <- [False, True]
+        , polymorphicType <- [False, True]
+        ])
   ]
   where
     theTest = testSessionWithExtraFiles "hover" def $ \dir -> do
@@ -1871,6 +1882,144 @@ suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields w
       contentAfterAction <- documentContents doc
       liftIO $ after @=? contentAfterAction
 
+    theTestIndirect qualifiedGhcRecords polymorphicType = testGroup
+      ((if qualifiedGhcRecords then "qualified-" else "unqualified-")
+      <> ("HasField " :: String)
+      <>
+      (if polymorphicType then "polymorphic-" else "monomorphic-")
+      <> "type ")
+      . (\x -> [x]) $ testSessionWithExtraFiles "hover" def $ \dir -> do
+      -- Hopefully enable project indexing?
+      configureCheckProject True
+
+      let
+          before = T.unlines ["{-# LANGUAGE OverloadedRecordDot #-}", "module A where", if qualifiedGhcRecords then "" else "import GHC.Records", "import C (bar)", "spam = bar.foo"]
+          after = T.unlines ["{-# LANGUAGE OverloadedRecordDot #-}", "module A where", if qualifiedGhcRecords then "" else "import GHC.Records", "import C (bar)", "import B (Foo(..))", "spam = bar.foo"]
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, B, C]}}"
+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
+      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["module B where", if polymorphicType then "data Foo x = Foo { foo :: x }" else "data Foo = Foo { foo :: Int }"]
+      liftIO $ writeFileUTF8 (dir </> "C.hs") $ unlines ["module C where", "import B", "bar = Foo 10" ]
+      doc <- createDoc "Test.hs" "haskell" before
+      waitForProgressDone
+      _ <- waitForDiagnostics
+      let defLine = 4
+          range = Range (Position defLine 0) (Position defLine maxBound)
+      actions <- getCodeActions doc range
+      action <- pickActionWithTitle "import B (Foo(..))" actions
+      executeCodeAction action
+      contentAfterAction <- documentContents doc
+      liftIO $ after @=? contentAfterAction
+
+suggestAddRecordFieldUpdateImportTests :: TestTree
+suggestAddRecordFieldUpdateImportTests = testGroup "suggest imports of record fields in update"
+  [ testGroup "implicit import of type" [theTest ] ]
+  where
+    theTest = testSessionWithExtraFiles "hover" def $ \dir -> do
+      configureCheckProject True
+
+      let
+          before = T.unlines ["module C where", "import B", "biz = bar { foo = 100 }"]
+          after = T.unlines ["module C where", "import B", "import A (Foo(..))", "biz = bar { foo = 100 }"]
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, B, C]}}"
+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
+      liftIO $ writeFileUTF8 (dir </> "A.hs") $ unlines ["module A where", "data Foo = Foo { foo :: Int }"]
+      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["module B where", "import A", "bar = Foo 10" ]
+      doc <- createDoc "Test.hs" "haskell" before
+      waitForProgressDone
+      diags <- waitForDiagnostics
+      liftIO $ print diags
+      let defLine = 2
+          range = Range (Position defLine 0) (Position defLine maxBound)
+      actions <- getCodeActions doc range
+      liftIO $ print actions
+      action <- pickActionWithTitle "import A (Foo(..))" actions
+      executeCodeAction action
+      contentAfterAction <- documentContents doc
+      liftIO $ after @=? contentAfterAction
+
+extractNotInScopeNameTests :: TestTree
+extractNotInScopeNameTests =
+  testGroup "extractNotInScopeName" [
+      testGroup "record field" [
+            testCase ">=ghc 910" $ Refactor.extractNotInScopeName "Not in scope: ‘foo’"  @=? Just (NotInScopeThing "foo"),
+            testCase "<ghc 910" $ Refactor.extractNotInScopeName "Not in scope: record field ‘foo’"  @=? Just (NotInScopeThing "foo")
+            ],
+      testGroup "HasField" [
+        testGroup "unqualified" [
+          testGroup "nice ticks" [
+            testCase "Simple type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"baz\" Cheval Bool’"  @=? Just (NotInScopeThing "Cheval"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"bar\" (Hibou Int) a0’"  @=? Just (NotInScopeThing "Hibou"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"foo\" (Tortue Int) Int’"  @=? Just (NotInScopeThing "Tortue")
+            ],
+          testGroup "parenthesis" [
+            testCase "Simple type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"blup\" Calamar Bool’"  @=? Just (NotInScopeThing "Calamar"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"biz\" (Ornithorink Int) a0’"  @=? Just (NotInScopeThing "Ornithorink"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘HasField \"blork\" (Salamandre Int) Int’"  @=? Just (NotInScopeThing "Salamandre")
+            ]
+          ],
+        testGroup "qualified" [
+          testGroup "nice ticks" [
+            testCase "Simple type" $ Refactor.extractNotInScopeName "No instance for ‘GHC.HasField \"baz\" Cheval Bool’"  @=? Just (NotInScopeThing "Cheval"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘Record.HasField \"bar\" (Hibou Int) a0’"  @=? Just (NotInScopeThing "Hibou"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘Youpi.HasField \"foo\" (Tortue Int) Int’"  @=? Just (NotInScopeThing "Tortue")
+            ],
+          testGroup "parenthesis" [
+            testCase "Simple type" $ Refactor.extractNotInScopeName "No instance for ‘GHC.Tortue.HasField \"blup\" Calamar Bool’"  @=? Just (NotInScopeThing "Calamar"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘Youpi.Salamandre.HasField \"biz\" (Ornithorink Int) a0’"  @=? Just (NotInScopeThing "Ornithorink"),
+            testCase "Parametric type" $ Refactor.extractNotInScopeName "No instance for ‘Foo.Bar.HasField \"blork\" (Salamandre Int) Int’"  @=? Just (NotInScopeThing "Salamandre")
+            ]
+          ]
+        ]
+    ]
+suggestAddCoerceMissingConstructorImportTests :: TestTree
+suggestAddCoerceMissingConstructorImportTests = testGroup "suggest imports of newtype constructor when using coerce"
+  [ testGroup "The newtype constructor is suggested when a matching representation error"
+    [ theTest
+    ]
+  ]
+  where
+    theTest = testSessionWithExtraFiles "hover" def $ \dir -> do
+      configureCheckProject False
+      let before = T.unlines ["module A where", "import Data.Coerce (coerce)", "import Data.Semigroup (Sum)", "bar = coerce (10 :: Int) :: Sum Int"]
+          after = T.unlines ["module A where", "import Data.Coerce (coerce)", "import Data.Semigroup (Sum)", "import Data.Semigroup (Sum(..))", "bar = coerce (10 :: Int) :: Sum Int"]
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A]}}"
+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
+      doc <- createDoc "Test.hs" "haskell" before
+      waitForProgressDone
+      _ <- waitForDiagnostics
+      let defLine = 3
+          range = Range (Position defLine 0) (Position defLine maxBound)
+      actions <- getCodeActions doc range
+      action <- pickActionWithTitle "import Data.Semigroup (Sum(..))" actions
+      executeCodeAction action
+      contentAfterAction <- documentContents doc
+      liftIO $ after @=? contentAfterAction
+
+suggestAddGenericMissingConstructorImportTests :: TestTree
+suggestAddGenericMissingConstructorImportTests = testGroup "suggest imports of type constructors when using generic deriving"
+  [ testGroup "The type constructors are suggested when not in scope"
+    [ theTest
+    ]
+  ]
+  where
+    theTest = testSessionWithExtraFiles "hover" def $ \dir -> do
+      configureCheckProject False
+      let
+          before = T.unlines ["module A where", "import GHC.Generics", "import Data.Semigroup (Sum)", "deriving instance Generic (Sum Int)"]
+          after = T.unlines ["module A where", "import GHC.Generics", "import Data.Semigroup (Sum)", "import Data.Semigroup (Sum(..))", "deriving instance Generic (Sum Int)"]
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A]}}"
+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
+      doc <- createDoc "Test.hs" "haskell" before
+      waitForProgressDone
+      _ <- waitForDiagnostics
+      let defLine = 3
+          range = Range (Position defLine 0) (Position defLine maxBound)
+      actions <- getCodeActions doc range
+      action <- pickActionWithTitle "import Data.Semigroup (Sum(..))" actions
+      executeCodeAction action
+      contentAfterAction <- documentContents doc
+      liftIO $ after @=? contentAfterAction
+
 
 suggestImportDisambiguationTests :: TestTree
 suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions"