From c7cd09e8809d264e64b201a158966b0d8fe7e3c9 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Mon, 1 Feb 2021 03:53:49 +0900 Subject: [PATCH] ghcide: Implements a CodeAction to disambiguate ambiguous symbols (#1264) * wip * Draft completed * Removes Unuseds * Redundant extension * linting * Makes HLint happy * tweak for transfer annotation logic (not working) * Initial implementation done * Import list reorder * Remove redundant fmt * lint * Missing import * Excludes false-positive qualified imports * A first test (not enough though) * fmt.sh * Some more test cases * More test cases * Ah! CRLF have bitten me! * Tentative workaround for #1274 * Wait much to ensure rewrite suggestion to be collected * Tests for type suggestion * Slightly more wait * A little smarter waiting strartegy for actions * Import list slim up * Adjusted to the master * Update ghcide/src/Development/IDE/Plugin/CodeAction.hs Co-authored-by: Pepe Iborra * Rewrote using `expectDiagnostics` * Case for Prelude.++ * Corrects test name * Renames `rawIEWrapName` to `unqualIEWrapName`, and moved to the appropriate module * Rewrote qualifying strategy with `Rewrite` * Use exactprint also for hideImplicitPreludeSymbol * Unify exact actions and `suggestImportDisambiguation` * Moves a comment to the right place * Won't panic on errornous input, let HLS keep going * No, each errornous rewrite must not be dropped seprately, but discarded as a whole * Update ghcide/src/Development/IDE/Spans/Common.hs Co-authored-by: Potato Hatsue * ieNames * Makes Splice plugin compiles * Stop using nfp * Since there is global `setEntryDPT dp00`, we don't add offset here * Removes redundant (why warned here?) * Made `hideImplicitPreludeSymbol` total Co-authored-by: Pepe Iborra Co-authored-by: Potato Hatsue --- ghcide/src/Development/IDE/GHC/Error.hs | 18 ++ ghcide/src/Development/IDE/GHC/Orphans.hs | 1 - .../src/Development/IDE/Plugin/CodeAction.hs | 187 ++++++++++++++++-- .../IDE/Plugin/CodeAction/ExactPrint.hs | 153 +++++++++++--- ghcide/src/Development/IDE/Spans/Common.hs | 6 + ghcide/test/data/hiding/AVec.hs | 20 ++ ghcide/test/data/hiding/BVec.hs | 20 ++ ghcide/test/data/hiding/CVec.hs | 20 ++ ghcide/test/data/hiding/DVec.hs | 20 ++ ghcide/test/data/hiding/EVec.hs | 20 ++ ghcide/test/data/hiding/HideFunction.hs | 11 ++ .../hiding/HideFunction.hs.expected.append.E | 12 ++ .../HideFunction.hs.expected.append.Prelude | 11 ++ .../HideFunction.hs.expected.fromList.A | 11 ++ .../HideFunction.hs.expected.fromList.B | 11 ++ ...ction.hs.expected.qualified.append.Prelude | 11 ++ ...eFunction.hs.expected.qualified.fromList.E | 11 ++ .../test/data/hiding/HidePreludeIndented.hs | 4 + .../hiding/HidePreludeIndented.hs.expected | 5 + ghcide/test/data/hiding/HideType.hs | 9 + .../test/data/hiding/HideType.hs.expected.A | 9 + .../test/data/hiding/HideType.hs.expected.E | 9 + ghcide/test/data/hiding/hie.yaml | 10 + ghcide/test/exe/Main.hs | 108 +++++++++- .../src/Ide/Plugin/Splice.hs | 20 +- 25 files changed, 659 insertions(+), 58 deletions(-) create mode 100644 ghcide/test/data/hiding/AVec.hs create mode 100644 ghcide/test/data/hiding/BVec.hs create mode 100644 ghcide/test/data/hiding/CVec.hs create mode 100644 ghcide/test/data/hiding/DVec.hs create mode 100644 ghcide/test/data/hiding/EVec.hs create mode 100644 ghcide/test/data/hiding/HideFunction.hs create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.append.E create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.append.Prelude create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.fromList.A create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.fromList.B create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.qualified.append.Prelude create mode 100644 ghcide/test/data/hiding/HideFunction.hs.expected.qualified.fromList.E create mode 100644 ghcide/test/data/hiding/HidePreludeIndented.hs create mode 100644 ghcide/test/data/hiding/HidePreludeIndented.hs.expected create mode 100644 ghcide/test/data/hiding/HideType.hs create mode 100644 ghcide/test/data/hiding/HideType.hs.expected.A create mode 100644 ghcide/test/data/hiding/HideType.hs.expected.E create mode 100644 ghcide/test/data/hiding/hie.yaml diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index bce5cc733f..9e06ea9a5c 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index be3c830794..e9a5e91538 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -22,7 +22,6 @@ import qualified StringBuffer as SB import Data.Text (Text) import Data.String (IsString(fromString)) import Retrie.ExactPrint (Annotated) -import Data.List (foldl') -- Orphan instances for types from the GHC API. diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 882374a8bd..e966522373 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -43,16 +43,22 @@ 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 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 qualified Data.DList as DL +import Development.IDE.Spans.Common +import OccName +import qualified GHC.LanguageExtensions as Lang +import Control.Lens (alaf) +import Data.Monoid (Ap(..)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -103,10 +109,12 @@ mkCA title diags edit = rewrite :: Maybe DynFlags -> Maybe (Annotated ParsedSource) -> - (DynFlags -> ParsedSource -> [(T.Text, Rewrite)]) -> + (DynFlags -> ParsedSource -> [(T.Text, [Rewrite])]) -> [(T.Text, [TextEdit])] rewrite (Just df) (Just ps) f - | Right edit <- (traverse . traverse) (rewriteToEdit df (annsA ps)) (f df $ astA ps) = edit + | Right edit <- (traverse . traverse) + (alaf Ap foldMap (rewriteToEdit df (annsA ps))) + (f df $ astA ps) = edit rewrite _ _ _ = [] suggestAction @@ -118,10 +126,13 @@ suggestAction -> Maybe (Annotated ParsedSource) -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource diag = concat +suggestAction packageExports ideOptions parsedModule text df annSource diag = + concat -- Order these suggestions by priority [ suggestSignature True diag , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag + , rewrite df annSource $ \df ps -> + suggestImportDisambiguation df ps diag , suggestFillTypeWildcard diag , suggestFixConstructorImport text diag , suggestModuleTypo diag @@ -301,8 +312,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 _ _ _ = [] @@ -377,7 +388,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 _ _ _ _ = [] @@ -655,7 +666,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 @@ -676,7 +687,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 ] @@ -694,6 +705,143 @@ 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 :: + DynFlags -> + ParsedSource -> + Diagnostic -> + [(T.Text, [Rewrite])] +suggestImportDisambiguation 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 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 = any ((== symb). showNameWithoutUniques) . ieNames + +targetModuleName :: ModuleTarget -> ModuleName +targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" +targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = + unLoc ideclName +targetModuleName (ExistingImp _) = + error "Cannot happen!" + +disambiguateSymbol :: + ParsedSource -> + Diagnostic -> + T.Text -> + HidingMode -> + [Rewrite] +disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case + (HideOthers hiddens0) -> + [ hideSymbol symbol idecl + | ExistingImp idecls <- hiddens0 + , idecl <- NE.toList idecls + ] + ++ mconcat + [ if null imps + then maybeToList $ hideImplicitPreludeSymbol symbol pm + else hideSymbol symbol <$> imps + | ImplicitPrelude imps <- hiddens0 + ] + (ToQualified qualMod) -> + let occSym = mkVarOcc symbol + rdr = Qual qualMod occSym + in [ Rewrite (rangeToSrcSpan "" _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 @@ -711,13 +859,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 (:[])) $ codeAction diag missingConstraint | otherwise = [] where findMissingConstraint :: T.Text -> Maybe T.Text @@ -773,14 +921,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 @@ -1098,11 +1246,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 diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 00b521b615..49114c70d0 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -6,30 +6,40 @@ module Development.IDE.Plugin.CodeAction.ExactPrint ( Rewrite (..), rewriteToEdit, + transferAnn, -- * Utilities appendConstraint, extendImport, + hideImplicitPreludeSymbol, + hideSymbol, + liftParseAST, ) where import Control.Applicative import Control.Monad import Control.Monad.Trans +import Data.Char (isAlphaNum) import Data.Data (Data) import Data.Functor import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T import Development.IDE.GHC.Compat hiding (parseExpr) import Development.IDE.GHC.ExactPrint -import Development.IDE.Types.Location -import GhcPlugins (realSrcSpanEnd, realSrcSpanStart, sigPrec) + ( Annotate, ASTElement(parseAST) ) +import FieldLabel (flLabel) +import GhcPlugins (sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.Haskell.LSP.Types import OccName -import Outputable (ppr, showSDocUnsafe) +import Outputable (ppr, showSDocUnsafe, showSDoc) +import Retrie.GHC (rdrNameOcc, unpackFS, mkRealSrcSpan, realSrcSpanEnd) +import Development.IDE.Spans.Common +import Development.IDE.GHC.Error +import Safe (lastMay) ------------------------------------------------------------------------------ @@ -53,26 +63,14 @@ rewriteToEdit :: Rewrite -> Either String [TextEdit] rewriteToEdit dflags anns (Rewrite dst f) = do - (ast, (anns, _), _) <- runTransformT anns $ f dflags + (ast, (anns, _), _) <- runTransformT anns $ do + ast <- f dflags + ast <$ setEntryDPT ast (DP (0,0)) let editMap = [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ tail $ exactPrint ast anns + T.pack $ exactPrint ast anns ] pure editMap -srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real - -realSrcSpanToRange :: RealSrcSpan -> Range -realSrcSpanToRange real = - Range - (realSrcLocToPosition $ realSrcSpanStart real) - (realSrcLocToPosition $ realSrcSpanEnd real) - -realSrcLocToPosition :: RealSrcLoc -> Position -realSrcLocToPosition real = - Position (srcLocLine real - 1) (srcLocCol real - 1) - ------------------------------------------------------------------------------ -- | Fix the parentheses around a type context @@ -137,10 +135,9 @@ appendConstraint constraintT = go lContext <- uniqueSrcSpanT lTop <- uniqueSrcSpanT let context = L lContext [constraint] - addSimpleAnnT context (DP (0, 1)) $ - [ (G AnnDarrow, DP (0, 1)) - ] - ++ concat + addSimpleAnnT context (DP (0, 0)) $ + (G AnnDarrow, DP (0, 1)) + : concat [ [ (G AnnOpenP, dp00), (G AnnCloseP, dp00) ] @@ -290,3 +287,111 @@ unqalDP paren = else pure ) (G AnnVal, dp00) + +------------------------------------------------------------------------------ +-- | Hide a symbol from import declaration +hideSymbol :: + String -> LImportDecl GhcPs -> Rewrite +hideSymbol symbol lidecl@(L loc ImportDecl {..}) = + case ideclHiding of + Nothing -> Rewrite loc $ extendHiding symbol lidecl Nothing + Just (True, hides) -> Rewrite loc $ extendHiding symbol lidecl (Just hides) + Just (False, imports) -> Rewrite loc $ deleteFromImport symbol lidecl imports +hideSymbol _ (L _ (XImportDecl _)) = + error "cannot happen" + +extendHiding :: + String -> + LImportDecl GhcPs -> + Maybe (Located [LIE GhcPs]) -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +extendHiding symbol (L l idecls) mlies df = do + L l' lies <- case mlies of + Nothing -> flip L [] <$> uniqueSrcSpanT + Just pr -> pure pr + let hasSibling = not $ null lies + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + rdr <- liftParseAST df symbol + let lie = L src $ IEName rdr + x = L top $ IEVar noExtField lie + singleHide = L l' [x] + when (isNothing mlies) $ do + addSimpleAnnT + singleHide + dp00 + [ (G AnnHiding, DP (0, 1)) + , (G AnnOpenP, DP (0, 1)) + , (G AnnCloseP, DP (0, 0)) + ] + addSimpleAnnT x (DP (0, 0)) [] + addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr + if hasSibling + then when hasSibling $ do + addTrailingCommaT x + addSimpleAnnT (head lies) (DP (0, 1)) [] + unless (null $ tail lies) $ + addTrailingCommaT (head lies) -- Why we need this? + else forM_ mlies $ \lies0 -> do + transferAnn lies0 singleHide id + return $ L l idecls {ideclHiding = Just (True, L l' $ x : lies)} + where + isOperator = not . all isAlphaNum . occNameString . rdrNameOcc + +deleteFromImport :: + String -> + LImportDecl GhcPs -> + Located [LIE GhcPs] -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ =do + let edited = L lieLoc deletedLies + lidecl' = L l $ idecl + { ideclHiding = Just (False, edited) + } + when (not (null lies) && null deletedLies) $ do + transferAnn llies edited id + addSimpleAnnT edited dp00 + [(G AnnOpenP, DP (0, 1)) + ,(G AnnCloseP, DP (0,0)) + ] + pure lidecl' + where + deletedLies = + mapMaybe killLie lies + killLie :: LIE GhcPs -> Maybe (LIE GhcPs) + killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) + | nam == symbol = Nothing + | otherwise = Just $ + L lieL $ IEThingWith xt ty wild + (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) + (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) + killLie v = Just v + +hideImplicitPreludeSymbol + :: String -> ParsedSource -> Maybe Rewrite +hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do + existingImp <- lastMay hsmodImports + exisImpSpan <- realSpan $ getLoc existingImp + let indentation = srcSpanStartCol exisImpSpan + beg = realSrcSpanEnd exisImpSpan + ran = RealSrcSpan $ mkRealSrcSpan beg beg + pure $ Rewrite ran $ \df -> do + let symOcc = mkVarOcc symbol + symImp = T.pack $ showSDoc df $ parenSymOcc symOcc $ ppr symOcc + impStmt = "import Prelude hiding (" <> symImp <> ")" + + -- Re-labeling is needed to reflect annotations correctly + L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df $ T.unpack impStmt + let idecl = L ran idecl0 + addSimpleAnnT idecl (DP (1,indentation - 1)) + [(G AnnImport, DP (1, indentation - 1))] + pure idecl diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index e7ad090e5e..479c908c2a 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -6,6 +6,7 @@ module Development.IDE.Spans.Common ( showGhc , showNameWithoutUniques +, unqualIEWrapName , safeTyThingId , safeTyThingType , SpanDoc(..) @@ -35,6 +36,7 @@ import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util +import RdrName (rdrNameOcc) type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing @@ -52,6 +54,10 @@ showNameWithoutUniques = T.pack . prettyprint prettyprint x = renderWithStyle dyn (ppr x) style style = mkUserStyle dyn neverQualify AllTheWay +-- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. +unqualIEWrapName :: IEWrappedName RdrName -> T.Text +unqualIEWrapName = showNameWithoutUniques . rdrNameOcc . ieWrappedName + -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs safeTyThingType :: TyThing -> Maybe Type safeTyThingType thing diff --git a/ghcide/test/data/hiding/AVec.hs b/ghcide/test/data/hiding/AVec.hs new file mode 100644 index 0000000000..4c1ea30874 --- /dev/null +++ b/ghcide/test/data/hiding/AVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/ghcide/test/data/hiding/BVec.hs b/ghcide/test/data/hiding/BVec.hs new file mode 100644 index 0000000000..e086bb6ff4 --- /dev/null +++ b/ghcide/test/data/hiding/BVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/ghcide/test/data/hiding/CVec.hs b/ghcide/test/data/hiding/CVec.hs new file mode 100644 index 0000000000..4a5fd3e7e9 --- /dev/null +++ b/ghcide/test/data/hiding/CVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/ghcide/test/data/hiding/DVec.hs b/ghcide/test/data/hiding/DVec.hs new file mode 100644 index 0000000000..a580ca907d --- /dev/null +++ b/ghcide/test/data/hiding/DVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/ghcide/test/data/hiding/EVec.hs b/ghcide/test/data/hiding/EVec.hs new file mode 100644 index 0000000000..f5e0b2c269 --- /dev/null +++ b/ghcide/test/data/hiding/EVec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeOperators #-} +module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where + +import Prelude hiding ((++)) + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined + +data (@@@) a b + +fromList :: [a] -> Vec a +fromList = undefined + +cons :: a -> Vec a -> Vec a +cons = undefined + +snoc :: Vec a -> a -> Vec a +snoc = undefined diff --git a/ghcide/test/data/hiding/HideFunction.hs b/ghcide/test/data/hiding/HideFunction.hs new file mode 100644 index 0000000000..ade8f63ac5 --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.append.E b/ghcide/test/data/hiding/HideFunction.hs.expected.append.E new file mode 100644 index 0000000000..94d333b24a --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.append.E @@ -0,0 +1,12 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList,) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E +import Prelude hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.append.Prelude b/ghcide/test/data/hiding/HideFunction.hs.expected.append.Prelude new file mode 100644 index 0000000000..0b202451f0 --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.append.Prelude @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList,) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) + +theFun = fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.A b/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.A new file mode 100644 index 0000000000..b91d83f98b --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.A @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec ( (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.B b/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.B new file mode 100644 index 0000000000..e131d86c1c --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.fromList.B @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec () +import BVec (fromList, (++)) +import CVec hiding (fromList, cons) +import DVec hiding (fromList, cons, snoc) +import EVec as E hiding (fromList) + +theFun = fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.append.Prelude b/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.append.Prelude new file mode 100644 index 0000000000..505125f55a --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.append.Prelude @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = fromList + +theOp = (Prelude.++) diff --git a/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.fromList.E b/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.fromList.E new file mode 100644 index 0000000000..e81909ce0f --- /dev/null +++ b/ghcide/test/data/hiding/HideFunction.hs.expected.qualified.fromList.E @@ -0,0 +1,11 @@ +module HideFunction where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theFun = E.fromList + +theOp = (++) diff --git a/ghcide/test/data/hiding/HidePreludeIndented.hs b/ghcide/test/data/hiding/HidePreludeIndented.hs new file mode 100644 index 0000000000..122b64a390 --- /dev/null +++ b/ghcide/test/data/hiding/HidePreludeIndented.hs @@ -0,0 +1,4 @@ +module HidePreludeIndented where + + import AVec + op = (++) diff --git a/ghcide/test/data/hiding/HidePreludeIndented.hs.expected b/ghcide/test/data/hiding/HidePreludeIndented.hs.expected new file mode 100644 index 0000000000..4218338bee --- /dev/null +++ b/ghcide/test/data/hiding/HidePreludeIndented.hs.expected @@ -0,0 +1,5 @@ +module HidePreludeIndented where + + import AVec + import Prelude hiding ((++)) + op = (++) diff --git a/ghcide/test/data/hiding/HideType.hs b/ghcide/test/data/hiding/HideType.hs new file mode 100644 index 0000000000..926cedf15d --- /dev/null +++ b/ghcide/test/data/hiding/HideType.hs @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/ghcide/test/data/hiding/HideType.hs.expected.A b/ghcide/test/data/hiding/HideType.hs.expected.A new file mode 100644 index 0000000000..a59de871b4 --- /dev/null +++ b/ghcide/test/data/hiding/HideType.hs.expected.A @@ -0,0 +1,9 @@ +module HideType where + +import AVec (Vec, fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E hiding (Vec) + +type TheType = Vec diff --git a/ghcide/test/data/hiding/HideType.hs.expected.E b/ghcide/test/data/hiding/HideType.hs.expected.E new file mode 100644 index 0000000000..51fa6610b5 --- /dev/null +++ b/ghcide/test/data/hiding/HideType.hs.expected.E @@ -0,0 +1,9 @@ +module HideType where + +import AVec ( fromList) +import BVec (fromList, (++)) +import CVec hiding (Vec, cons) +import DVec hiding (Vec, cons, snoc) +import EVec as E + +type TheType = Vec diff --git a/ghcide/test/data/hiding/hie.yaml b/ghcide/test/data/hiding/hie.yaml new file mode 100644 index 0000000000..075686555e --- /dev/null +++ b/ghcide/test/data/hiding/hie.yaml @@ -0,0 +1,10 @@ +cradle: + direct: + arguments: + - -Wall + - HideFunction.hs + - AVec.hs + - BVec.hs + - CVec.hs + - DVec.hs + - EVec.hs diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index bf912b686c..6d6b9538db 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -33,6 +33,16 @@ import Data.Typeable import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common import Development.IDE.Test + ( canonicalizeUri, + diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, + standardizeQuotes, + waitForAction, + Cursor ) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -682,6 +692,7 @@ codeActionTests = testGroup "code actions" , removeImportTests , extendImportTests , suggestImportTests + , suggestImportDisambiguationTests , disableWarningTests , fixConstructorImportTests , importRenameActionTests @@ -1464,6 +1475,101 @@ suggestImportTests = testGroup "suggest import actions" else liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] +suggestImportDisambiguationTests :: TestTree +suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" + [ testGroup "Hiding strategy works" + [ testGroup "fromList" + [ testCase "AVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use AVec for fromList, hiding other imports" + "HideFunction.hs.expected.fromList.A" + , testCase "BVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use BVec for fromList, hiding other imports" + "HideFunction.hs.expected.fromList.B" + ] + , testGroup "(++)" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use EVec for ++, hiding other imports" + "HideFunction.hs.expected.append.E" + , testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use Prelude for ++, hiding other imports" + "HideFunction.hs.expected.append.Prelude" + , testCase "AVec, indented" $ + compareTwo "HidePreludeIndented.hs" [(3,8)] + "Use AVec for ++, hiding other imports" + "HidePreludeIndented.hs.expected" + + ] + , testGroup "Vec (type)" + [ testCase "AVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use AVec for Vec, hiding other imports" + "HideType.hs.expected.A" + , testCase "EVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use EVec for Vec, hiding other imports" + "HideType.hs.expected.E" + ] + ] + , testGroup "Qualify strategy" + [ testCase "won't suggest full name for qualified module" $ + withHideFunction [(8,9),(10,8)] $ \_ actions -> do + liftIO $ + assertBool "EVec.fromList must not be suggested" $ + "Replace with qualified: EVec.fromList" `notElem` + [ actionTitle + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + liftIO $ + assertBool "EVec.++ must not be suggested" $ + "Replace with qualified: EVec.++" `notElem` + [ actionTitle + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + , testGroup "fromList" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: E.fromList" + "HideFunction.hs.expected.qualified.fromList.E" + ] + , testGroup "(++)" + [ testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: Prelude.++" + "HideFunction.hs.expected.qualified.append.Prelude" + ] + ] + ] + where + hidingDir = "test/data/hiding" + compareTwo original locs cmd expected = + withTarget original locs $ \doc actions -> do + expected <- liftIO $ + readFileUtf8 (hidingDir expected) + action <- liftIO $ pickActionWithTitle cmd actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction + compareHideFunctionTo = compareTwo "HideFunction.hs" + auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs"] + withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do + liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) + $ file : auxFiles + doc <- openDoc file "haskell" + void (skipManyTill anyMessage message + :: Session WorkDoneProgressEndNotification) + void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] + contents <- documentContents doc + let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) + actions <- getCodeActions doc range + k doc actions + withHideFunction = withTarget ("HideFunction" <.> "hs") + disableWarningTests :: TestTree disableWarningTests = testGroup "disable warnings" $ @@ -2890,7 +2996,7 @@ findDefinitionAndHoverTests = let Position{_line = l + 1, _character = c + 1} in case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c + [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c _ -> liftIO $ assertFailure $ "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> "\n but got: " <> show (msg, rangeInHover) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 44e6d3d3bc..373be9f919 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -47,12 +47,11 @@ import Ide.Plugin.Splice.Types import Ide.PluginUtils (mkLspCommand, responseError) import Development.IDE.GHC.ExactPrint import Ide.Types -import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint (setPrecedingLines, uniqueSrcSpanT) import Language.Haskell.LSP.Core import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as J -import Retrie.ExactPrint (Annotated) import RnSplice import TcRnMonad import Data.Foldable (Foldable(foldl')) @@ -392,10 +391,7 @@ codeAction _ state plId docId ran _ = ParsedModule {..} <- MaybeT . runAction "splice.codeAction.GitHieAst" state $ use GetParsedModule fp - let spn = - rangeToRealSrcSpan ran $ - fromString $ - fromNormalizedFilePath fp + let spn = rangeToRealSrcSpan fp ran mouterSplice = something' (detectSplice spn) pm_parsed_source mcmds <- forM mouterSplice $ \(spliceSpan, spliceContext) -> @@ -459,15 +455,3 @@ something' f = go case f x of Stop -> Nothing resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x) - -posToRealSrcLoc :: Position -> FastString -> RealSrcLoc -posToRealSrcLoc pos fs = mkRealSrcLoc fs (line + 1) (col + 1) - where - line = _line pos - col = _character pos - -rangeToRealSrcSpan :: Range -> FastString -> RealSrcSpan -rangeToRealSrcSpan ran fs = - mkRealSrcSpan - (posToRealSrcLoc (_start ran) fs) - (posToRealSrcLoc (_end ran) fs)