diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 21c1f716d2..82bdb9b3e5 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -58,6 +58,13 @@ import OccName import qualified GHC.LanguageExtensions as Lang import Control.Lens (alaf) import Data.Monoid (Ap(..)) +import TcRnTypes (TcGblEnv(..), ImportAvails(..)) +import HscTypes (ImportedModsVal(..), importedByUser) +import RdrName (GlobalRdrElt(..), lookupGlobalRdrEnv) +import SrcLoc (realSrcSpanStart) +import Module (moduleEnvElts) +import qualified Data.Map as M +import qualified Data.Set as S descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -80,11 +87,13 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS) <- runAction "CodeAction" state $ - (,,,) <$> getIdeOptions + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $ + (,,,,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile <*> use GetAnnotatedParsedSource `traverse` mbFile + <*> use TypeCheck `traverse` mbFile + <*> use GetHieAst `traverse` mbFile -- This is quite expensive 0.6-0.7s on GHC pkgExports <- maybe mempty envPackageExports env localExports <- readVar (exportsMap $ shakeExtras state) @@ -93,7 +102,7 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di df = ms_hspp_opts . pm_mod_summary <$> parsedModule actions = [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS x + | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri @@ -123,9 +132,11 @@ suggestAction -> Maybe T.Text -> Maybe DynFlags -> Maybe (Annotated ParsedSource) + -> Maybe TcModuleResult + -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource diag = +suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag = concat -- Order these suggestions by priority [ suggestSignature True diag @@ -140,6 +151,7 @@ suggestAction packageExports ideOptions parsedModule text df annSource diag = , suggestAddTypeAnnotationToSatisfyContraints text diag , rewrite df annSource $ \df ps -> suggestConstraint df ps diag , rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag + , rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag ] ++ concat [ suggestNewDefinition ideOptions pm text diag ++ suggestNewImport packageExports pm diag @@ -169,6 +181,81 @@ findInstanceHead df instanceHead decls = findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) +-- Single: +-- This binding for ‘mod’ shadows the existing binding +-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 +-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) +-- Multi: +--This binding for ‘pack’ shadows the existing bindings +-- imported from ‘Data.ByteString’ at B.hs:6:1-22 +-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 +-- imported from ‘Data.Text’ at B.hs:7:1-16 +suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Rewrite])] +suggestHideShadow pm@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range} + | Just [identifier, modName, s] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = + suggests identifier modName s + | Just [identifier] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing bindings", + Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", + mods <- [(modName, s) | [_, modName, s] <- matched], + result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), + hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = + result <> [hideAll] + | otherwise = [] + where + suggests identifier modName s + | Just tcM <- mTcM, + Just har <- mHar, + [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then [(title, maybeToList $ hideImplicitPreludeSymbol (T.unpack identifier) pm)] + else maybeToList $ (title,) . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] + +findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) +findImportDeclByModuleName decls modName = flip find decls $ \case + (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) + _ -> error "impossible" + +isTheSameLine :: SrcSpan -> SrcSpan -> Bool +isTheSameLine s1 s2 + | Just sl1 <- getStartLine s1, + Just sl2 <- getStartLine s2 = + sl1 == sl2 + | otherwise = False + where + getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x + +isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool +isUnusedImportedId + TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} + HAR {refMap} + identifier + modName + importSpan + | occ <- mkVarOcc identifier, + impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, + Just rdrEnv <- + listToMaybe + [ imv_all_exports + | ImportedModsVal {..} <- impModsVals, + imv_name == mkModuleName modName, + isTheSameLine imv_span importSpan + ], + [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right gre_name, + refs <- M.lookup importedIdentifier refMap = + maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs + | otherwise = False + suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDisableWarning pm contents Diagnostic{..} | Just (StringValue (T.stripPrefix "-W" -> Just w)) <- _code = diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 68198752c9..86c1defd4d 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -31,7 +31,7 @@ import Development.IDE.GHC.Compat hiding (parseExpr) import Development.IDE.GHC.ExactPrint ( Annotate, ASTElement(parseAST) ) import FieldLabel (flLabel) -import GhcPlugins (sigPrec) +import GhcPlugins (sigPrec, mkRealSrcLoc) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.Haskell.LSP.Types @@ -40,9 +40,9 @@ 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) import Data.Generics (listify) import GHC.Exts (IsList (fromList)) +import Control.Monad.Extra (whenJust) ------------------------------------------------------------------------------ @@ -205,6 +205,7 @@ extendImport mparent identifier lDecl@(L l _) = -- extendImportTopLevel "foo" AST: -- -- import A --> Error +-- import A (foo) --> Error -- import A (bar) --> import A (bar, foo) extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) extendImportTopLevel df idnetifier (L l it@ImportDecl {..}) @@ -382,6 +383,8 @@ deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ =do lidecl' = L l $ idecl { ideclHiding = Just (False, edited) } + -- avoid import A (foo,) + whenJust (lastMaybe deletedLies) removeTrailingCommaT when (not (null lies) && null deletedLies) $ do transferAnn llies edited id addSimpleAnnT edited dp00 @@ -408,13 +411,16 @@ deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ =do (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) killLie v = Just v +-- | Insert a import declaration hiding a symbole from Prelude hideImplicitPreludeSymbol :: String -> ParsedSource -> Maybe Rewrite hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do - existingImp <- lastMay hsmodImports - exisImpSpan <- realSpan $ getLoc existingImp - let indentation = srcSpanStartCol exisImpSpan - beg = realSrcSpanEnd exisImpSpan + let predLine old = mkRealSrcLoc (srcLocFile old) (srcLocLine old - 1) (srcLocCol old) + existingImpSpan = (fmap (id,) . realSpan . getLoc) =<< lastMaybe hsmodImports + existingDeclSpan = (fmap (predLine, ) . realSpan . getLoc) =<< headMaybe hsmodDecls + (f, s) <- existingImpSpan <|> existingDeclSpan + let beg = f $ realSrcSpanEnd s + indentation = srcSpanStartCol s ran = RealSrcSpan $ mkRealSrcSpan beg beg pure $ Rewrite ran $ \df -> do let symOcc = mkVarOcc symbol @@ -424,6 +430,6 @@ hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do -- 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)) + addSimpleAnnT idecl (DP (1, indentation - 1)) [(G AnnImport, DP (1, indentation - 1))] pure idecl diff --git a/ghcide/test/data/hiding/HideFunction.expected.append.E.hs b/ghcide/test/data/hiding/HideFunction.expected.append.E.hs index 94d333b24a..3448baa4f4 100644 --- a/ghcide/test/data/hiding/HideFunction.expected.append.E.hs +++ b/ghcide/test/data/hiding/HideFunction.expected.append.E.hs @@ -1,7 +1,7 @@ module HideFunction where import AVec (fromList) -import BVec (fromList,) +import BVec (fromList) import CVec hiding ((++), cons) import DVec hiding ((++), cons, snoc) import EVec as E diff --git a/ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs b/ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs index 0b202451f0..78d1cd879b 100644 --- a/ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs +++ b/ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs @@ -1,7 +1,7 @@ module HideFunction where import AVec (fromList) -import BVec (fromList,) +import BVec (fromList) import CVec hiding ((++), cons) import DVec hiding ((++), cons, snoc) import EVec as E hiding ((++)) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index de6c7876d9..271549eab8 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -693,6 +693,7 @@ codeActionTests = testGroup "code actions" , removeImportTests , extendImportTests , suggestImportTests + , suggestHideShadowTests , suggestImportDisambiguationTests , disableWarningTests , fixConstructorImportTests @@ -1586,6 +1587,193 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti k doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- liftIO $ pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (CACodeAction ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) + void $ k [x | x@(CACodeAction ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + disableWarningTests :: TestTree disableWarningTests = testGroup "disable warnings" $