diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 8d77a41559..bfe3221fd3 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -153,6 +153,7 @@ suggestAction packageExports ideOptions parsedModule text df annSource tcM har d , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag , rewrite df annSource $ \df ps -> suggestImportDisambiguation df text ps diag + , rewrite df annSource $ \_ ps -> suggestNewOrExtendImportForClassMethod packageExports ps diag , suggestFillTypeWildcard diag , suggestFixConstructorImport text diag , suggestModuleTypo diag @@ -769,8 +770,6 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ = mod_srcspan >>= uncurry (suggestions hsmodImports binding) | otherwise = [] where - unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) - unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) suggestions decls binding mod srcspan | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of [s] -> let x = realSrcSpanToRange s @@ -1158,6 +1157,39 @@ removeRedundantConstraints mContents Diagnostic{..} ------------------------------------------------------------------------------------------------- +suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])] +suggestNewOrExtendImportForClassMethod packageExportsMap ps Diagnostic {_message} + | Just [methodName, className] <- + matchRegexUnifySpaces + _message + "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", + idents <- + maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ + Map.lookup methodName $ getExportsMap packageExportsMap = + mconcat $ suggest <$> idents + | otherwise = [] + where + suggest identInfo@IdentInfo {moduleNameText} + | importStyle <- NE.toList $ importStyles identInfo, + mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) = + case mImportDecl of + -- extend + Just decl -> + [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, + [uncurry extendImport (unImportStyle style) decl] + ) + | style <- importStyle + ] + -- new + _ -> + [ ( "Import " <> moduleNameText <> " with " <> rendered, + maybeToList $ newUnqualImport (T.unpack moduleNameText) (T.unpack rendered) False ps + ) + | style <- importStyle, + let rendered = renderImportStyle style + ] + <> maybeToList (("Import " <> moduleNameText,) <$> fmap pure (newImportAll (T.unpack moduleNameText) ps)) + suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message} | msg <- unifySpaces _message @@ -1451,3 +1483,6 @@ renderImportStyle :: ImportStyle -> T.Text renderImportStyle (ImportTopLevel x) = x renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" +unImportStyle :: ImportStyle -> (Maybe String, String) +unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) +unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 520887cd71..7f591a47d4 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -3,20 +3,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -module Development.IDE.Plugin.CodeAction.ExactPrint - ( Rewrite (..), - rewriteToEdit, - rewriteToWEdit, - transferAnn, - - -- * Utilities - appendConstraint, - extendImport, - hideImplicitPreludeSymbol, - hideSymbol, - liftParseAST, - ) -where +module Development.IDE.Plugin.CodeAction.ExactPrint ( + Rewrite (..), + rewriteToEdit, + rewriteToWEdit, + transferAnn, + + -- * Utilities + appendConstraint, + extendImport, + hideImplicitPreludeSymbol, + hideSymbol, + liftParseAST, + newImport, + newUnqualImport, + newImportAll, +) where import Control.Applicative import Control.Monad @@ -37,7 +39,9 @@ import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), import Development.IDE.Spans.Common import FieldLabel (flLabel) import GHC.Exts (IsList (fromList)) -import GhcPlugins (mkRealSrcLoc, sigPrec) +import GhcPlugins (mkRealSrcLoc, + realSrcSpanStart, + sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) @@ -73,22 +77,23 @@ rewriteToEdit :: Either String [TextEdit] rewriteToEdit dflags anns (Rewrite dst f) = do (ast, (anns, _), _) <- runTransformT anns $ do - ast <- f dflags - ast <$ setEntryDPT ast (DP (0,0)) - let editMap = [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ exactPrint ast anns - ] + ast <- f dflags + ast <$ setEntryDPT ast (DP (0, 0)) + let editMap = + [ TextEdit (fromJust $ srcSpanToRange dst) $ + T.pack $ exactPrint ast anns + ] pure editMap -- | Convert a 'Rewrite' into a 'WorkspaceEdit' rewriteToWEdit :: DynFlags -> Uri -> Anns -> Rewrite -> Either String WorkspaceEdit rewriteToWEdit dflags uri anns r = do - edits <- rewriteToEdit dflags anns r - return $ - WorkspaceEdit - { _changes = Just (fromList [(uri, List edits)]) - , _documentChanges = Nothing - } + edits <- rewriteToEdit dflags anns r + return $ + WorkspaceEdit + { _changes = Just (fromList [(uri, List edits)]) + , _documentChanges = Nothing + } ------------------------------------------------------------------------------ @@ -116,12 +121,12 @@ fixParens openDP closeDP ctxt@(L _ elems) = do ) (mkAnnKey ctxt) return $ map dropHsParTy elems - where - parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] + where + parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] - dropHsParTy :: LHsType pass -> LHsType pass - dropHsParTy (L _ (HsParTy _ ty)) = ty - dropHsParTy other = other + dropHsParTy :: LHsType pass -> LHsType pass + dropHsParTy (L _ (HsParTy _ ty)) = ty + dropHsParTy other = other -- | Append a constraint at the end of a type context. -- If no context is present, a new one will be created. @@ -132,37 +137,37 @@ appendConstraint :: LHsType GhcPs -> Rewrite appendConstraint constraintT = go - where - go (L l it@HsQualTy {hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do - constraint <- liftParseAST df constraintT - setEntryDPT constraint (DP (0, 1)) - - -- Paren annotations are usually attached to the first and last constraints, - -- rather than to the constraint list itself, so to preserve them we need to reposition them - closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt - openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt - ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) - - addTrailingCommaT (last ctxt') - - return $ L l $ it {hst_ctxt = L l' $ ctxt' ++ [constraint]} - go (L _ HsForAllTy {hst_body}) = go hst_body - go (L _ (HsParTy _ ty)) = go ty - go (L l other) = Rewrite l $ \df -> do - -- there isn't a context, so we must create one - constraint <- liftParseAST df constraintT - lContext <- uniqueSrcSpanT - lTop <- uniqueSrcSpanT - let context = L lContext [constraint] - addSimpleAnnT context (DP (0, 0)) $ - (G AnnDarrow, DP (0, 1)) - : concat - [ [ (G AnnOpenP, dp00), - (G AnnCloseP, dp00) - ] - | hsTypeNeedsParens sigPrec $ unLoc constraint - ] - return $ L lTop $ HsQualTy noExtField context (L l other) + where + go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do + constraint <- liftParseAST df constraintT + setEntryDPT constraint (DP (0, 1)) + + -- Paren annotations are usually attached to the first and last constraints, + -- rather than to the constraint list itself, so to preserve them we need to reposition them + closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt + openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt + ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) + + addTrailingCommaT (last ctxt') + + return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]} + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L _ (HsParTy _ ty)) = go ty + go (L l other) = Rewrite l $ \df -> do + -- there isn't a context, so we must create one + constraint <- liftParseAST df constraintT + lContext <- uniqueSrcSpanT + lTop <- uniqueSrcSpanT + let context = L lContext [constraint] + addSimpleAnnT context (DP (0, 0)) $ + (G AnnDarrow, DP (0, 1)) : + concat + [ [ (G AnnOpenP, dp00) + , (G AnnCloseP, dp00) + ] + | hsTypeNeedsParens sigPrec $ unLoc constraint + ] + return $ L lTop $ HsQualTy noExtField context (L l other) liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast) liftParseAST df s = case parseAST df "" s of @@ -214,31 +219,33 @@ extendImport mparent identifier lDecl@(L l _) = -- 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 {..}) - | Just (hide, L l' lies) <- ideclHiding, - hasSibling <- not $ null lies = do +extendImportTopLevel df idnetifier (L l it@ImportDecl{..}) + | Just (hide, L l' lies) <- ideclHiding + , hasSibling <- not $ null lies = do src <- uniqueSrcSpanT top <- uniqueSrcSpanT rdr <- liftParseAST df idnetifier let alreadyImported = - showNameWithoutUniques (occName (unLoc rdr)) `elem` - map (showNameWithoutUniques @OccName) (listify (const True) lies) + showNameWithoutUniques (occName (unLoc rdr)) + `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies) when alreadyImported $ - lift (Left $ idnetifier <> " already imported") + lift (Left $ idnetifier <> " already imported") let lie = L src $ IEName rdr x = L top $ IEVar noExtField lie - if x `elem` lies then lift (Left $ idnetifier <> " already imported") else do + if x `elem` lies + then lift (Left $ idnetifier <> " already imported") + else do when hasSibling $ - addTrailingCommaT (last lies) + addTrailingCommaT (last lies) addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier -- Parens are attachted to `lies`, so if `lies` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ - transferAnn (L l' lies) (L l' [x]) id - return $ L l it {ideclHiding = Just (hide, L l' $ lies ++ [x])} + transferAnn (L l' lies) (L l' [x]) id + return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" -- | Add an identifier with its parent to import list @@ -252,64 +259,64 @@ extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" -- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) -- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) -extendImportViaParent df parent child (L l it@ImportDecl {..}) +extendImportViaParent df parent child (L l it@ImportDecl{..}) | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies - where - go :: Bool -> SrcSpan -> [LIE GhcPs] -> [LIE GhcPs] -> TransformT (Either String) (LImportDecl GhcPs) - go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) - | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" - go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) - -- ThingAbs ie => ThingWith ie child - | parent == unIEWrappedName ie = do - srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child - let childLIE = L srcChild $ IEName childRdr - x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] - -- take anns from ThingAbs, and attatch parens to it - transferAnn lAbs x $ \old -> old {annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} - addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} - go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) - -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) - | parent == unIEWrappedName ie, - hasSibling <- not $ null lies' = - do - srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child - - let alreadyImported = - showNameWithoutUniques(occName (unLoc childRdr)) `elem` - map (showNameWithoutUniques @OccName) (listify (const True) lies') - when alreadyImported $ - lift (Left $ child <> " already included in " <> parent <> " imports") - - when hasSibling $ - addTrailingCommaT (last lies') - let childLIE = L srcChild $ IEName childRdr - addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} - go hide l' pre (x : xs) = go hide l' (x : pre) xs - go hide l' pre [] - | hasSibling <- not $ null pre = do - -- [] => ThingWith parent [child] - l'' <- uniqueSrcSpanT - srcParent <- uniqueSrcSpanT + where + go :: Bool -> SrcSpan -> [LIE GhcPs] -> [LIE GhcPs] -> TransformT (Either String) (LImportDecl GhcPs) + go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) + | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" + go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) + -- ThingAbs ie => ThingWith ie child + | parent == unIEWrappedName ie = do + srcChild <- uniqueSrcSpanT + childRdr <- liftParseAST df child + let childLIE = L srcChild $ IEName childRdr + x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] + -- take anns from ThingAbs, and attatch parens to it + transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} + addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} + go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) + -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) + | parent == unIEWrappedName ie + , hasSibling <- not $ null lies' = + do srcChild <- uniqueSrcSpanT - parentRdr <- liftParseAST df parent childRdr <- liftParseAST df child + + let alreadyImported = + showNameWithoutUniques (occName (unLoc childRdr)) + `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies') + when alreadyImported $ + lift (Left $ child <> " already included in " <> parent <> " imports") + when hasSibling $ - addTrailingCommaT (head pre) - let parentLIE = L srcParent $ IEName parentRdr - childLIE = L srcChild $ IEName childRdr - x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] - addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent - addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child - addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] - -- Parens are attachted to `pre`, so if `pre` was empty previously, - -- we need change the ann key from `[]` to `:` to keep parens and other anns. - unless hasSibling $ - transferAnn (L l' $ reverse pre) (L l' [x]) id - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} + addTrailingCommaT (last lies') + let childLIE = L srcChild $ IEName childRdr + addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} + go hide l' pre (x : xs) = go hide l' (x : pre) xs + go hide l' pre [] + | hasSibling <- not $ null pre = do + -- [] => ThingWith parent [child] + l'' <- uniqueSrcSpanT + srcParent <- uniqueSrcSpanT + srcChild <- uniqueSrcSpanT + parentRdr <- liftParseAST df parent + childRdr <- liftParseAST df child + when hasSibling $ + addTrailingCommaT (head pre) + let parentLIE = L srcParent $ IEName parentRdr + childLIE = L srcChild $ IEName childRdr + x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] + addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent + addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child + addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] + -- Parens are attachted to `pre`, so if `pre` was empty previously, + -- we need change the ann key from `[]` to `:` to keep parens and other anns. + unless hasSibling $ + transferAnn (L l' $ reverse pre) (L l' [x]) id + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String @@ -328,114 +335,166 @@ unqalDP paren = (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 + 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" + error "cannot happen" extendHiding :: - String -> - LImportDecl GhcPs -> - Maybe (Located [LIE GhcPs]) -> - DynFlags -> - TransformT (Either String) (LImportDecl GhcPs) + 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 + 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 + 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) } - -- avoid import A (foo,) - whenJust (lastMaybe deletedLies) removeTrailingCommaT - 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 - --- | Insert a import declaration hiding a symbole from Prelude -hideImplicitPreludeSymbol - :: String -> ParsedSource -> Maybe Rewrite -hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do - 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 - 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 + -- avoid import A (foo,) + whenJust (lastMaybe deletedLies) removeTrailingCommaT + 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 + +-- | Insert a import declaration with at most one symbol + +-- newImport "A" (Just "Bar(Cons)") Nothing False --> import A (Bar(Cons)) +-- newImport "A" (Just "foo") Nothing True --> import A hiding (foo) +-- newImport "A" Nothing (Just "Q") False --> import qualified A as Q +-- +-- Wrong combinations will result in parse error +-- Returns Nothing if there is no imports and declarations +newImport :: + -- | module name + String -> + -- | the symbol + Maybe String -> + -- | whether to be qualified + Maybe String -> + -- | the symbol is to be imported or hidden + Bool -> + ParsedSource -> + Maybe Rewrite +newImport modName mSymbol mQual hiding (L _ HsModule{..}) = do + -- TODO (berberman): if the previous line is module name and there is no other imports, + -- 'AnnWhere' will be crowded out to the next line, which is a bug + let predLine old = + mkRealSrcLoc + (srcLocFile old) + (srcLocLine old - 1) + (srcLocCol old) + existingImpSpan = (fmap (realSrcSpanEnd,) . realSpan . getLoc) =<< lastMaybe hsmodImports + existingDeclSpan = (fmap (predLine . realSrcSpanStart,) . realSpan . getLoc) =<< headMaybe hsmodDecls + (f, s) <- existingImpSpan <|> existingDeclSpan + let beg = f s + indentation = srcSpanStartCol s + ran = RealSrcSpan $ mkRealSrcSpan beg beg + pure $ + Rewrite ran $ \df -> do + let symImp + | Just symbol <- mSymbol + , symOcc <- mkVarOcc symbol = + "(" <> showSDoc df (parenSymOcc symOcc $ ppr symOcc) <> ")" + | otherwise = "" + impStmt = + "import " + <> maybe "" (const "qualified ") mQual + <> modName + <> (if hiding then " hiding " else " ") + <> symImp + <> maybe "" (" as " <>) mQual + -- Re-labeling is needed to reflect annotations correctly + L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df impStmt + let idecl = L ran idecl0 + addSimpleAnnT + idecl + (DP (1, indentation - 1)) + [(G AnnImport, DP (1, indentation - 1))] + pure idecl + +newUnqualImport :: String -> String -> Bool -> ParsedSource -> Maybe Rewrite +newUnqualImport modName symbol = newImport modName (Just symbol) Nothing + +newImportAll :: String -> ParsedSource -> Maybe Rewrite +newImportAll modName = newImport modName Nothing Nothing False + +-- | Insert "import Prelude hiding (symbol)" +hideImplicitPreludeSymbol :: String -> ParsedSource -> Maybe Rewrite +hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 19cdb344c6..c34e97df50 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -712,6 +712,7 @@ codeActionTests = testGroup "code actions" , typeWildCardActionTests , removeImportTests , extendImportTests + , suggesImportClassMethodTests , suggestImportTests , suggestHideShadowTests , suggestImportDisambiguationTests @@ -1426,7 +1427,92 @@ extendImportTestsRegEx = testGroup "regex parsing" template message expected = do liftIO $ matchRegExMultipleImports message @=? expected - +suggesImportClassMethodTests :: TestTree +suggesImportClassMethodTests = + testGroup + "suggest import class methods" + [ testGroup + "new" + [ testSession "via parent" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup with Semigroup(stimes)" + [ "module A where", + "", + "import Data.Semigroup (Semigroup(stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup with stimes" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ], + testSession "all" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup" + ] + ], + testGroup + "extend" + [ testSession "via parent" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add Semigroup(stimes) to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (Semigroup (stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add stimes to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ] + ] + ] + where + decls = + [ "data X = X", + "instance Semigroup X where", + " (<>) _ _ = X", + " stimes _ _ = X" + ] + template beforeContent range executeTitle expectedContent = do + doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) + _ <- waitForDiagnostics + waitForProgressDone + actions <- getCodeActions doc range + let actions' = [x | InR x <- actions] + titles = [_title | CodeAction {_title} <- actions'] + liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles + executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' + content <- documentContents doc + liftIO $ T.unlines (expectedContent <> decls) @=? content suggestImportTests :: TestTree suggestImportTests = testGroup "suggest import actions"