ghcide: Implements a CodeAction to disambiguate ambiguous symbols

ghcide/src/Development/IDE/GHC/Error.hs

@@ -17,6 +17,9 @@ module Development.IDE.GHC.Error
   , realSrcLocToPosition
   , realSrcSpanToLocation
   , srcSpanToFilename
+  , rangeToSrcSpan
+  , rangeToRealSrcSpan
+  , positionToRealSrcLoc
   , zeroSpan
   , realSpan
   , isInsideSrcSpan
@@ -39,6 +42,7 @@ import Panic
 import           ErrUtils
 import           SrcLoc
 import qualified Outputable                 as Out
+import Data.String (fromString)
 
 
 
@@ -102,6 +106,20 @@ srcSpanToLocation src = do
   -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
   pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng
 
+rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
+rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan
+
+rangeToRealSrcSpan
+    :: NormalizedFilePath -> Range -> RealSrcSpan
+rangeToRealSrcSpan nfp =
+    mkRealSrcSpan
+        <$> positionToRealSrcLoc nfp . _start
+        <*> positionToRealSrcLoc nfp . _end
+
+positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
+positionToRealSrcLoc nfp (Position l c)=
+    mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1)
+
 isInsideSrcSpan :: Position -> SrcSpan -> Bool
 p `isInsideSrcSpan` r = case srcSpanToRange r of
   Just (Range sp ep) -> sp <= p && p <= ep

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -43,16 +43,26 @@ import qualified Data.Text as T
 import Text.Regex.TDFA (mrAfter, (=~), (=~~))
 import Outputable (Outputable, ppr, showSDoc, showSDocUnsafe)
 import Data.Function
-import Control.Arrow ((>>>))
+import Control.Arrow ((>>>), second)
 import Data.Functor
-import Control.Applicative ((<|>))
+import Control.Applicative ((<|>), Applicative (liftA2))
 import Safe (atMay)
 import Bag (isEmptyBag)
 import qualified Data.HashSet as Set
 import Control.Concurrent.Extra (readVar)
-import Development.IDE.GHC.Util (printRdrName)
+import Development.IDE.GHC.Util (printRdrName, prettyPrint)
 import Ide.PluginUtils (subRange)
 import Ide.Types
+import Data.Hashable (Hashable)
+import qualified Data.DList as DL
+import Development.IDE.Spans.Common
+import OccName
+import Data.Coerce
+import qualified GHC.LanguageExtensions as Lang
+import Control.Lens (foldMapBy)
+import FieldLabel (flLabel)
+import FastString (unpackFS)
+import Data.Monoid (Ap(Ap, getAp))
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId =
@@ -94,35 +104,51 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di
       actions' =
           [mkCA title [x] edit
           | x <- xs
-          , Just ps <- [annotatedPS]
-          , Just dynflags <- [df]
-          , (title, graft) <- suggestExactAction exportsMap dynflags ps x
-          , Right edit <-
-                [ -- either (Left . traceShow) Right $
-                 rewriteToEdit dynflags uri (annsA ps) graft
-                 ]
+          , ps <- maybeToList annotatedPS
+          , dynflags <- maybeToList df
+          , nfp <- maybeToList mbFile
+          , (title, grafts) <- suggestExactAction exportsMap nfp dynflags ps x
+          , Right edit
+              <- [getAp $ foldMapBy (liftA2 unionWSEdit) mempty
+                      (Ap . rewriteToEdit dynflags uri (annsA ps)) grafts]
           ]
       actions'' = caRemoveRedundantImports parsedModule text diag xs uri
                <> actions
                <> actions'
                <> caRemoveInvalidExports parsedModule text diag xs uri
     pure $ Right $ List actions''
 
+-- | Semigroup instance just overrides duplicated keys in the first argument
+unionWSEdit :: WorkspaceEdit -> WorkspaceEdit -> WorkspaceEdit
+unionWSEdit (WorkspaceEdit a b) (WorkspaceEdit c d) =
+    WorkspaceEdit (runCatHashMap <$> fmap CatHashMap a <> fmap CatHashMap c)
+        (b <> d)
+
+-- | A monoidal hashmap
+     -- FIXME: Want to use monoidal-containers, but it supports aeson <1.5 only...
+newtype CatHashMap k v = CatHashMap { runCatHashMap :: Map.HashMap k v }
+instance (Eq k, Hashable k, Semigroup v) => Semigroup (CatHashMap k v) where
+  (<>) = coerce $ Map.unionWith @k @v (<>)
+instance (Eq k, Hashable k, Semigroup v) => Monoid (CatHashMap k v) where
+  mempty = CatHashMap mempty
+
 mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult
 mkCA title diags edit =
   CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing
 
 suggestExactAction ::
   ExportsMap ->
+  NormalizedFilePath ->
   DynFlags ->
   Annotated ParsedSource ->
   Diagnostic ->
-  [(T.Text, Rewrite)]
-suggestExactAction exportsMap df ps x =
+  [(T.Text, [Rewrite])]
+suggestExactAction exportsMap nfp df ps x =
   concat
     [ suggestConstraint df (astA ps) x
     , suggestImplicitParameter (astA ps) x
     , suggestExtendImport exportsMap (astA ps) x
+    , suggestImportDisambiguation nfp df (astA ps) x
     ]
 
 suggestAction
@@ -312,8 +338,8 @@ suggestDeleteUnusedBinding
             let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig
                 findSig _ = []
             in
-              [extendForSpaces indexedContent $ toRange l]
-              ++ concatMap findSig hsmodDecls
+              extendForSpaces indexedContent (toRange l) :
+              concatMap findSig hsmodDecls
           _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches
       findRelatedSpans _ _ _ = []
 
@@ -388,7 +414,7 @@ suggestDeleteUnusedBinding
         then
           let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig
               findSig _ = []
-          in [extendForSpaces indexedContent $ toRange l] ++ concatMap findSig lsigs
+          in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs
         else concatMap (findRelatedSpanForMatch indexedContent name) matches
       findRelatedSpanForHsBind _ _ _ _ = []
 
@@ -666,7 +692,7 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
 indentation :: T.Text -> Int
 indentation = T.length . T.takeWhile isSpace
 
-suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
+suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])]
 suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}
     | Just [binding, mod, srcspan] <-
       matchRegexUnifySpaces _message
@@ -687,7 +713,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
             Just decl <- findImportDeclByRange decls range,
             Just ident <- lookupExportMap binding mod
           = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod
-              , uncurry extendImport (unImportStyle importStyle) decl
+              , [uncurry extendImport (unImportStyle importStyle) decl]
               )
             | importStyle <- NE.toList $ importStyles ident
             ]
@@ -705,6 +731,155 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
                 , parent = Nothing
                 , isDatacon = False}
 
+data HidingMode = HideOthers [ModuleTarget]
+                | ToQualified ModuleName
+    deriving (Show)
+
+data ModuleTarget
+    = ExistingImp (NonEmpty (LImportDecl GhcPs))
+    | ImplicitPrelude [LImportDecl GhcPs]
+    deriving (Show)
+
+targetImports :: ModuleTarget -> [LImportDecl GhcPs]
+targetImports (ExistingImp ne) = NE.toList ne
+targetImports (ImplicitPrelude xs) = xs
+
+oneAndOthers :: [a] -> [(a, [a])]
+oneAndOthers = go
+    where
+        go [] = []
+        go (x : xs) = (x, xs) : map (second (x :)) (go xs)
+
+isPreludeImplicit :: DynFlags -> Bool
+isPreludeImplicit = xopt Lang.ImplicitPrelude
+
+-- | Suggests disambiguation for ambiguous symbols.
+suggestImportDisambiguation ::
+    NormalizedFilePath ->
+    DynFlags ->
+    ParsedSource ->
+    Diagnostic ->
+    [(T.Text, [Rewrite])]
+suggestImportDisambiguation nfp df ps@(L _ HsModule {hsmodImports}) diag@Diagnostic {..}
+    | Just [ambiguous] <-
+        matchRegexUnifySpaces
+            _message
+            "Ambiguous occurrence ‘([^’]+)’"
+      , Just modules <-
+            map last
+                <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" =
+        suggestions ambiguous modules
+    | otherwise = []
+    where
+        locDic =
+            fmap (NE.fromList . DL.toList) $
+            Map.fromListWith (<>) $
+                map
+                    ( \i@(L _ idecl) ->
+                        ( T.pack $ moduleNameString $ unLoc $ ideclName idecl
+                        , DL.singleton i
+                        )
+                    )
+                    hsmodImports
+        toModuleTarget "Prelude"
+            | isPreludeImplicit df
+             = Just $ ImplicitPrelude $
+                maybe [] NE.toList (Map.lookup "Prelude" locDic)
+        toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic
+
+        suggestions symbol mods
+            | Just targets <- mapM toModuleTarget mods =
+                sortOn fst
+                [ ( renderUniquify mode modNameText symbol
+                  , disambiguateSymbol nfp ps diag symbol mode
+                  )
+                | (modTarget, restImports) <- oneAndOthers targets
+                , let modName = targetModuleName modTarget
+                      modNameText = T.pack $ moduleNameString modName
+                , mode <-
+                    HideOthers restImports :
+                    [ ToQualified qual
+                    | ExistingImp imps <- [modTarget]
+                    , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc)
+                        $ NE.toList imps
+                    ]
+                    ++ [ToQualified modName
+                        | any (occursUnqualified symbol . unLoc)
+                            (targetImports modTarget)
+                        || case modTarget of
+                            ImplicitPrelude{} -> True
+                            _ -> False
+                        ]
+                ]
+            | otherwise = []
+        renderUniquify HideOthers {} modName symbol =
+            "Use " <> modName <> " for " <> symbol <> ", hiding other imports"
+        renderUniquify (ToQualified qual) _ symbol =
+            "Replace with qualified: "
+                <> T.pack (moduleNameString qual)
+                <> "."
+                <> symbol
+
+occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool
+occursUnqualified symbol ImportDecl{..}
+    | isNothing ideclAs = Just False /=
+            -- I don't find this particularly comprehensible,
+            -- but HLint suggested me to do so...
+        (ideclHiding <&> \(isHiding, L _ ents) ->
+            let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents
+            in isHiding && not occurs || not isHiding && occurs
+        )
+occursUnqualified _ _ = False
+
+symbolOccursIn :: T.Text -> IE GhcPs -> Bool
+symbolOccursIn symb = \case
+   IEVar _ (L _ n) -> unqualIEWrapName n == symb
+   IEThingAbs _ (L _ n) -> unqualIEWrapName n == symb
+   IEThingAll _ (L _ n) -> unqualIEWrapName n == symb
+   IEThingWith _ (L _ n) _ ents flds ->
+    unqualIEWrapName n == symb
+    || any ((== symb) . unqualIEWrapName . unLoc) ents
+    || any ((== symb) . T.pack . unpackFS . flLabel . unLoc) flds
+   IEModuleContents{} -> False
+   IEGroup{} -> False
+   IEDoc{} -> False
+   IEDocNamed{} -> False
+   XIE{} -> False
+
+targetModuleName :: ModuleTarget -> ModuleName
+targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"
+targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =
+    unLoc ideclName
+targetModuleName (ExistingImp _) =
+    error "Cannot happen!"
+
+disambiguateSymbol ::
+    NormalizedFilePath  ->
+    ParsedSource ->
+    Diagnostic ->
+    T.Text ->
+    HidingMode ->
+    [Rewrite]
+disambiguateSymbol nfp pm Diagnostic {..} (T.unpack -> symbol) = \case
+    (HideOthers hiddens0) ->
+        [ hideSymbol symbol idecl
+        | ExistingImp idecls <- hiddens0
+        , idecl <- NE.toList idecls
+        ]
+            ++ mconcat
+                [ if null imps
+                    then [hideImplicitPreludeSymbol symbol pm]
+                    else hideSymbol symbol <$> imps
+                | ImplicitPrelude imps <- hiddens0
+                ]
+    (ToQualified qualMod) ->
+        let occSym = mkVarOcc symbol
+            rdr = Qual qualMod occSym
+        in [Rewrite (rangeToSrcSpan nfp _range) $ \df -> do
+            liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField
+                $ L (UnhelpfulSpan "") rdr
+            ]
+
 findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)
 findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs
 
@@ -722,13 +897,13 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
     in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
   | otherwise = []
 -- | Suggests a constraint for a declaration for which a constraint is missing.
-suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
+suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])]
 suggestConstraint df parsedModule diag@Diagnostic {..}
   | Just missingConstraint <- findMissingConstraint _message
   = let codeAction = if _message =~ ("the type signature for:" :: String)
                         then suggestFunctionConstraint df parsedModule
                         else suggestInstanceConstraint df parsedModule
-     in codeAction diag missingConstraint
+     in map (second pure) $ codeAction diag missingConstraint
   | otherwise = []
     where
       findMissingConstraint :: T.Text -> Maybe T.Text
@@ -784,14 +959,14 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
 suggestImplicitParameter ::
   ParsedSource ->
   Diagnostic ->
-  [(T.Text, Rewrite)]
+  [(T.Text, [Rewrite])]
 suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range}
   | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising",
     Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls,
     Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls
     =
       [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)
-        , appendConstraint (T.unpack implicitT) hsib_body)]
+        , [appendConstraint (T.unpack implicitT) hsib_body])]
   | otherwise = []
 
 findTypeSignatureName :: T.Text -> Maybe T.Text
@@ -1109,11 +1284,22 @@ rangesForBinding' _ _ = []
 matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
 matchRegexUnifySpaces message = matchRegex (unifySpaces message)
 
+-- | 'allMatchRegex' combined with 'unifySpaces'
+allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]]
+allMatchRegexUnifySpaces message =
+    allMatchRegex (unifySpaces message)
+
 -- | Returns Just (the submatches) for the first capture, or Nothing.
 matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
 matchRegex message regex = case message =~~ regex of
     Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
     Nothing -> Nothing
+
+-- | Returns Just (all matches) for the first capture, or Nothing.
+allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]]
+allMatchRegex message regex = message =~~ regex
+
+
 unifySpaces :: T.Text -> T.Text
 unifySpaces    = T.unwords . T.words