diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index f6ac664aa5..a833d16fa7 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -64,6 +64,7 @@ import Bag (isEmptyBag) import qualified Data.HashSet as Set import Control.Concurrent.Extra (threadDelay, readVar) import Development.IDE.GHC.Util (printRdrName) +import Ide.PluginUtils (subRange) plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens @@ -107,7 +108,8 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag [ mkCA title [x] edit | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] <> caRemoveRedundantImports parsedModule text diag xs uri + ] <> caRemoveInvalidExports parsedModule text diag xs uri + <> caRemoveRedundantImports parsedModule text diag xs uri actions' = [mkCA title [x] edit @@ -242,8 +244,8 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports , Just c <- contents - , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings) - , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges) + , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) + , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) , not (null ranges') = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] @@ -279,6 +281,69 @@ caRemoveRedundantImports m contents digs ctxDigs uri _edit = Just WorkspaceEdit{..} _command = Nothing +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveInvalidExports m contents digs ctxDigs uri + | Just pm <- m, + Just txt <- contents, + txt' <- indexedByPosition $ T.unpack txt, + r <- mapMaybe (groupDiag pm) digs, + r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, + caRemoveCtx <- mapMaybe removeSingle r', + allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], + allRanges' <- extend txt' allRanges, + Just caRemoveAll <- removeAll allRanges', + ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges + + groupDiag pm dig + | Just (title, ranges) <- suggestRemoveRedundantExport pm dig + = Just (title, dig, ranges) + | otherwise = Nothing + + removeSingle (_, _, []) = Nothing + removeSingle (title, diagnostic, ranges) = Just $ CACodeAction CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = title + _kind = Just CodeActionQuickFix + _diagnostics = Just $ List [diagnostic] + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + removeAll [] = Nothing + removeAll ranges = Just $ CACodeAction CodeAction {..} where + tedit = concatMap (\r -> [TextEdit r ""]) ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant exports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + +suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) +suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} + | msg <- unifySpaces _message + , Just export <- hsmodExports + , Just exportRange <- getLocatedRange export + , exports <- unLoc export + , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) + <|> (,[_range]) <$> matchExportItem msg + <|> (,[_range]) <$> matchDupExport msg + , subRange _range exportRange + = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) + where + matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" + matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" + getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of + [] -> (txt, [_range]) + ranges -> (txt, ranges) +suggestRemoveRedundantExport _ _ = Nothing + suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDeleteUnusedBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} @@ -395,6 +460,9 @@ suggestDeleteUnusedBinding data ExportsAs = ExportName | ExportPattern | ExportAll deriving (Eq) +getLocatedRange :: Located a -> Maybe Range +getLocatedRange = srcSpanToRange . getLoc + suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} -- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ @@ -435,9 +503,6 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" | otherwise = x - getLocatedRange :: Located a -> Maybe Range - getLocatedRange = srcSpanToRange . getLoc - matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool matchWithDiagnostic Range{_start=l,_end=r} x = let loc = fmap _start . getLocatedRange $ x @@ -1086,17 +1151,30 @@ textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) -- | Returns the ranges for a binding in an import declaration -rangesForBinding :: ImportDecl GhcPs -> String -> [Range] -rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b = +rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] +rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies where - b' = wrapOperatorInParens (unqualify b) + b' = modifyBinding b +rangesForBindingImport _ _ = [] +modifyBinding :: String -> String +modifyBinding = wrapOperatorInParens . unqualify + where wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")" - unqualify x = snd $ breakOnEnd "." x -rangesForBinding _ _ = [] +smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] +smallerRangesForBindingExport lies b = + concatMap (mapMaybe srcSpanToRange . ranges') lies + where + b' = modifyBinding b + ranges' (L _ (IEThingWith _ thing _ inners labels)) + | showSDocUnsafe (ppr thing) == b' = [] + | otherwise = + [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] ++ + [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] + ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index 7711eef5e9..622e942e5a 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -83,20 +83,27 @@ mergeRanges other = other -- a, b, |c| ===> a, b|, c| -- a, |b|, |c| ===> a|, b||, c| -- @ -extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range] -extendAllToIncludeCommaIfPossible indexedString = +-- +-- If 'acceptNoComma' is enabled, additional ranges are returned +-- +-- @ +-- |a| ===> |a| +-- |a|, |b| ===> |a,| |b| +-- @ +extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] +extendAllToIncludeCommaIfPossible acceptNoComma indexedString = mergeRanges . go indexedString . sortOn _start where go _ [] = [] go input (r : rr) - | r' : _ <- extendToIncludeCommaIfPossible input r + | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r , Just input' <- stripRange r' input = r' : go input' rr | otherwise = go input rr -extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range] -extendToIncludeCommaIfPossible indexedString range +extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] +extendToIncludeCommaIfPossible acceptNoComma indexedString range | Just (before, _, after) <- unconsRange range indexedString , after' <- dropWhile (isSpace . snd) after , before' <- dropWhile (isSpace . snd) (reverse before) @@ -109,6 +116,8 @@ extendToIncludeCommaIfPossible indexedString range | (_, ',') : rest <- [after'] , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest ] + ++ + ([range | acceptNoComma]) | otherwise = [range] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6101e29e11..fc095215e6 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -690,6 +690,7 @@ codeActionTests = testGroup "code actions" , addTypeAnnotationsToLiteralsTest , exportUnusedTests , addImplicitParamsConstraintTests + , removeExportTests ] codeActionHelperFunctionTests :: TestTree @@ -2479,7 +2480,7 @@ exportUnusedTests = testGroup "export unused actions" [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A (f) where" , "a `f` b = ()"]) - , testSession "function operator" $ template + , testSession "function operator" $ template (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" @@ -2559,19 +2560,199 @@ exportUnusedTests = testGroup "export unused actions" , "data (:<) = Foo ()"]) ] ] - where - template initialContent range expectedAction expectedContents = do - doc <- createDoc "A.hs" "haskell" initialContent - _ <- waitForDiagnostics - actions <- getCodeActions doc range - case expectedContents of - Just content -> do - action <- liftIO $ pickActionWithTitle expectedAction actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ content @=? contentAfterAction - Nothing -> - liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + where + template doc range = exportTemplate (Just range) doc + +exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () +exportTemplate mRange initialContent expectedAction expectedContents = do + doc <- createDoc "A.hs" "haskell" initialContent + _ <- waitForDiagnostics + actions <- case mRange of + Nothing -> getAllCodeActions doc + Just range -> getCodeActions doc range + case expectedContents of + Just content -> do + action <- liftIO $ pickActionWithTitle expectedAction actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ content @=? contentAfterAction + Nothing -> + liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +removeExportTests :: TestTree +removeExportTests = testGroup "remove export actions" + [ testSession "single export" $ template + (T.unlines + [ "module A ( a ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "ending comma" $ template + (T.unlines + [ "module A ( a, ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "multiple exports" $ template + (T.unlines + [ "module A (a , c, b ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + "Remove ‘b’ from export" + (Just $ T.unlines + [ "module A (a , c ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + , testSession "not in scope constructor" $ template + (T.unlines + [ "module A (A (X,Y,Z,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ]) + "Remove ‘Z’ from export" + (Just $ T.unlines + [ "module A (A (X,Y,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()"]) + , testSession "multiline export" $ template + (T.unlines + [ "module A (a" + , " , b" + , " , (:*:)" + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove ‘:*:’ from export" + (Just $ T.unlines + [ "module A (a" + , " , b" + , " " + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + , testSession "qualified re-export" $ template + (T.unlines + [ "module A (M.x,a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.x’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "export module" $ template + (T.unlines + [ "module A (module B) where" + , "a :: ()" + , "a = ()"]) + "Remove ‘module B’ from export" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "duplicate module export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L,module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + "Remove ‘Module L’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports single" $ template + (T.unlines + [ "module A (x) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports two" $ template + (T.unlines + [ "module A (x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports three" $ template + (T.unlines + [ "module A (a,x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (a) where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports composite" $ template + (T.unlines + [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (b, a, A(X, Y,getV), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + ] + where + template = exportTemplate Nothing addSigLensesTests :: TestTree addSigLensesTests = let diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 48c2c3e0c5..f22be647b2 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -18,7 +18,7 @@ module Ide.PluginUtils fullRange, mkLspCommand, mkLspCmdId, - allLspCmdIds,allLspCmdIds',installSigUsr1Handler) + allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange) where @@ -211,6 +211,18 @@ fullRange s = Range startPos endPos -} lastLine = length $ T.lines s +subRange :: Range -> Range -> Bool +subRange smallRange range = + positionInRange (_start smallRange) range + && positionInRange (_end smallRange) range + +positionInRange :: Position -> Range -> Bool +positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = + pl > sl && pl < el + || pl == sl && pl == el && po >= so && po <= eo + || pl == sl && po >= so + || pl == el && po <= eo + -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]