Fix completion snippets on DuplicateRecordFields (#1360)

* Use par_lbl rather than gre_name for field selectors * Add test
haskell · Feb 13, 2021 · e2bf01b · e2bf01b
1 parent 32e1fad
commit e2bf01b
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 15 deletions.
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -206,13 +206,13 @@ mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command
 mkAdditionalEditsCommand pId edits =
   mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])
 
-mkNameCompItem :: Uri -> Maybe T.Text -> Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
+mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
 mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..}
   where
-    compKind = occNameToComKind typeText $ occName origName
+    compKind = occNameToComKind typeText origName
     importedFrom = Right $ showModName origMod
-    isTypeCompl = isTcOcc $ occName origName
-    label = showGhc origName
+    isTypeCompl = isTcOcc origName
+    label = stripPrefix $ showGhc origName
     insertText = case isInfix of
             Nothing -> case getArgText <$> thingType of
                             Nothing -> label
@@ -345,10 +345,10 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d
       toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
       toCompItem par m mn n imp' = do
         docs <- getDocumentationTryGhc packageState curMod deps n
-        let mbParent = case par of
-                            NoParent -> Nothing
-                            ParentIs n -> Just (showNameWithoutUniques n)
-                            FldParent n _ -> Just (showNameWithoutUniques n)
+        let (mbParent, originName) = case par of
+                            NoParent -> (Nothing, nameOccName n)
+                            ParentIs n' -> (Just $ showNameWithoutUniques n', nameOccName n)
+                            FldParent n' lbl -> (Just $ showNameWithoutUniques n', maybe (nameOccName n) mkVarOccFS lbl)
         tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
                 name' <- lookupName packageState m n
                 return ( name' >>= safeTyThingType
@@ -361,7 +361,7 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d
                     [mkRecordSnippetCompItem uri mbParent  ctxStr flds (ppr mn) docs imp']
                 _ -> []
 
-        return $ mkNameCompItem uri mbParent n mn ty Nothing docs imp'
+        return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp'
                : recordCompls
 
   (unquals,quals) <- getCompls rdrElts
@@ -588,7 +588,7 @@ getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, impor
     -> return $ filtPragmaCompls (pragmaSuffix fullLine)
     | otherwise -> do
         let uniqueFiltCompls = nubOrdOn insertText filtCompls
-        compls <- mapM (mkCompl plId ideOpts . stripAutoGenerated) uniqueFiltCompls
+        compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls
         return $ filtModNameCompls
               ++ filtKeywordCompls
               ++ map ( toggleSnippets caps withSnippets) compls
@@ -657,16 +657,11 @@ openingBacktick line prefixModule prefixText Position { _character }
 
 -- | Under certain circumstance GHC generates some extra stuff that we
 -- don't want in the autocompleted symbols
-stripAutoGenerated :: CompItem -> CompItem
-stripAutoGenerated ci =
-    ci {label = stripPrefix (label ci)}
     {- When e.g. DuplicateRecordFields is enabled, compiler generates
     names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
     https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
     -}
-
 -- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
-
 stripPrefix :: T.Text -> T.Text
 stripPrefix name = T.takeWhile (/=':') $ go prefixes
   where

diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -3948,6 +3948,27 @@ otherCompletionTests = [
       (Position 3 11)
       [("Integer", CiStruct, "Integer ", True, True, Nothing)],
 
+    testSession "duplicate record fields" $ do
+      void $
+        createDoc "B.hs" "haskell" $
+          T.unlines
+            [ "{-# LANGUAGE DuplicateRecordFields #-}",
+              "module B where",
+              "newtype Foo = Foo { member :: () }",
+              "newtype Bar = Bar { member :: () }"
+            ]
+      docA <-
+        createDoc "A.hs" "haskell" $
+          T.unlines
+            [ "module A where",
+              "import B",
+              "memb"
+            ]
+      _ <- waitForDiagnostics
+      compls <- getCompletions docA $ Position 2 4
+      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]
+      liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"],
+
     testSessionWait "maxCompletions" $ do
         doc <- createDoc "A.hs" "haskell" $ T.unlines
             [ "{-# OPTIONS_GHC -Wunused-binds #-}",