From 791add26f66823c8e7a13edd3279d39b45febf55 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Fri, 12 Feb 2021 23:20:19 +0800 Subject: [PATCH 1/2] Use par_lbl rather than gre_name for field selectors --- .../IDE/Plugin/Completions/Logic.hs | 25 ++++++++----------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index de4d0e210a..4a4990be8f 100644 --- 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 From 05d81a23a7f69bef69e178610809e74052d050ee Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sat, 13 Feb 2021 15:06:18 +0800 Subject: [PATCH 2/2] Add test --- ghcide/test/exe/Main.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 877ddd1f9c..a3ef8edd1d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3760,6 +3760,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 #-}",