@@ -12,6 +12,7 @@ module Development.IDE.LSP.CodeAction
14import Language.Haskell.LSP.Types
14import Language.Haskell.LSP.Types
15+import Control.Monad (join)
15import Development.IDE.GHC.Compat
16import Development.IDE.GHC.Compat
16import Development.IDE.Core.Rules
17import Development.IDE.Core.Rules
17import Development.IDE.Core.RuleTypes
18import Development.IDE.Core.RuleTypes
@@ -33,6 +34,7 @@ import Data.List.Extra
33import qualified Data.Text as T
34import qualified Data.Text as T
34import Text.Regex.TDFA ((=~), (=~~))
35import Text.Regex.TDFA ((=~), (=~~))
35import Text.Regex.TDFA.Text()
36import Text.Regex.TDFA.Text()
37+import Outputable (ppr, showSDocUnsafe)
37-- | Generate code actions.
39-- | Generate code actions.
@@ -40,14 +42,15 @@ codeAction
40 -> IdeState
42 -> IdeState
41 -> CodeActionParams
43 -> CodeActionParams
42 -> IO (List CAResult)
44 -> IO (List CAResult)
43−codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
45+codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
44 -- disable logging as its quite verbose
46 -- disable logging as its quite verbose
45 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
47 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
46 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
48 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
47 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
49 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
50+ parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
48 pure $ List
51 pure $ List
49 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
52 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
50− | x <- xs, (title, tedit) <- suggestAction text x
53+ | x <- xs, (title, tedit) <- suggestAction ( join parsedModule ) text x
51 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
54 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
@@ -86,28 +89,29 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
86 | otherwise
89 | otherwise
87 = return (Null, Nothing)
90 = return (Null, Nothing)
89−suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
92+suggestAction :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
90−suggestAction text diag = concat
93+suggestAction parsedModule text diag = concat
91 [ suggestAddExtension diag
94 [ suggestAddExtension diag
92 , suggestExtendImport text diag
95 , suggestExtendImport text diag
93 , suggestFillHole diag
96 , suggestFillHole diag
94 , suggestFillTypeWildcard diag
97 , suggestFillTypeWildcard diag
95 , suggestFixConstructorImport text diag
98 , suggestFixConstructorImport text diag
96 , suggestModuleTypo diag
99 , suggestModuleTypo diag
97− , suggestRemoveRedundantImport text diag
98 , suggestReplaceIdentifier text diag
100 , suggestReplaceIdentifier text diag
99 , suggestSignature True diag
101 , suggestSignature True diag
103+ [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]]
103−suggestRemoveRedundantImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
106+suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
104−suggestRemoveRedundantImport contents Diagnostic{_range=_range@Range{..},..}
107+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}
105-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
108-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
106 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
109 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
110+ , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
107 , Just c <- contents
111 , Just c <- contents
108− , importLine <- textInRange _range c
112+ , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
113+ , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
109− = [( "Remove " <> bindings <> " from import"
114+ = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
110− , [TextEdit _range (dropBindingsFromImportLine (T.splitOn "," bindings) importLine)])]
112-- File.hs:16:1: warning:
116-- File.hs:16:1: warning:
113-- The import of `Data.List' is redundant
117-- The import of `Data.List' is redundant
@@ -357,44 +361,29 @@ textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
358 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
362 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
360−-- | Drop all occurrences of a binding in an import line.
364+-- | Returns the ranges for a binding in an import declaration
361−-- Preserves well-formedness but not whitespace between bindings.
365+rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
362−--
366+rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
363−-- >>> dropBindingsFromImportLine ["bA", "bC"] "import A(bA, bB,bC ,bA)"
367+ concatMap (map srcSpanToRange . rangesForBinding' b') lies
366−-- >>> dropBindingsFromImportLine ["+"] "import "P" qualified A as B ((+))"
367−-- "import "P" qualified A() as B hiding (bB)"
368−dropBindingsFromImportLine :: [T.Text] -> T.Text -> T.Text
369−dropBindingsFromImportLine bindings_ importLine =
370− importPre <> "(" <> importRest'
372− bindings = map (wrapOperatorInParens . removeQualified) bindings_
369+ b' = wrapOperatorInParens (unqualify b)
374− (importPre, importRest) = T.breakOn "(" importLine
376− wrapOperatorInParens x = if isAlpha (T.head x) then x else "(" <> x <> ")"
378− removeQualified x = case T.breakOn "." x of
371+ wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
379− (_qualifier, T.uncons -> Just (_, unqualified)) -> unqualified
382− importRest' = case T.uncons importRest of
373+ unqualify x = snd $ breakOnEnd "." x
386− $ mapMaybe (filtering . T.strip)
388− Nothing -> importRest
390− filtering x = case () of
375+rangesForBinding _ _ = []
391− () | x `elem` bindings -> Nothing
392− () | x `elem` map (<> ")") bindings -> Just ")"
395− joinCloseParens (x : ")" : rest) = (x <> ")") : joinCloseParens rest
377+rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
396− joinCloseParens (x : rest) = x : joinCloseParens rest
378+rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
397− joinCloseParens [] = []
379+rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
380+rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
381+rangesForBinding' b (L l (IEThingWith thing _ inners labels))
382+ | showSDocUnsafe (ppr thing) == b = [l]
384+ [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
385+ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
386+rangesForBinding' _ _ = []
399-- | Extends an import list with a new binding.
388-- | Extends an import list with a new binding.
400-- Assumes an import statement of the form:
389-- Assumes an import statement of the form:
@@ -428,3 +417,51 @@ setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
428 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
417 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
429 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
418 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
421+--------------------------------------------------------------------------------
423+type PositionIndexedString = [(Position, Char)]
425+indexedByPosition :: String -> PositionIndexedString
426+indexedByPosition = unfoldr f . (Position 0 0,) where
428+ f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))
429+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))
431+-- | Returns a tuple (before, contents, after)
432+unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
433+unconsRange Range {..} indexedString = (before, mid, after)
435+ (before, rest) = span ((/= _start) . fst) indexedString
436+ (mid, after) = span ((/= _end) . fst) rest
438+stripRange :: Range -> PositionIndexedString -> PositionIndexedString
439+stripRange r s = case unconsRange r s of
442+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
443+extendAllToIncludeCommaIfPossible _ [] = []
444+extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
446+ r' = case extendToIncludeCommaIfPossible indexedString r of
449+ indexedString' = stripRange r' indexedString
451+-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas
452+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
453+extendToIncludeCommaIfPossible indexedString range =
454+ -- a, |b|, c ===> a|, b|, c
455+ [ range{_start = start'}
456+ | (start', ',') : _ <- [before']
459+ -- a, |b|, c ===> a, |b, |c
460+ [ range{_end = end'}
461+ | (_, ',') : rest <- [after']
462+ , let (end', _) : _ = dropWhile (isSpace . snd) rest
465+ (before, _, after) = unconsRange range indexedString
466+ after' = dropWhile (isSpace . snd) after
467+ before' = dropWhile (isSpace . snd) (reverse before)