@@ -12,6 +12,7 @@ module Development.IDE.LSP.CodeAction
1212 ) where
1313
1414import Language.Haskell.LSP.Types
15+import Control.Monad (join)
1516import Development.IDE.GHC.Compat
1617import Development.IDE.Core.Rules
1718import Development.IDE.Core.RuleTypes
@@ -33,6 +34,7 @@ import Data.List.Extra
3334import qualified Data.Text as T
3435import Text.Regex.TDFA ((=~), (=~~))
3536import Text.Regex.TDFA.Text()
37+import Outputable (ppr, showSDocUnsafe)
3638
3739-- | Generate code actions.
3840codeAction
@@ -40,14 +42,15 @@ codeAction
4042 -> IdeState
4143 -> CodeActionParams
4244 -> 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
4446 -- disable logging as its quite verbose
4547 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
4648 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
4749 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
50+ parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
4851 pure $ List
4952 [ 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
5154 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
5255 ]
5356
@@ -86,28 +89,29 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
8689 | otherwise
8790 = return (Null, Nothing)
8891
89−suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
90−suggestAction text diag = concat
92+suggestAction :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
93+suggestAction parsedModule text diag = concat
9194 [ suggestAddExtension diag
9295 , suggestExtendImport text diag
9396 , suggestFillHole diag
9497 , suggestFillTypeWildcard diag
9598 , suggestFixConstructorImport text diag
9699 , suggestModuleTypo diag
97− , suggestRemoveRedundantImport text diag
98100 , suggestReplaceIdentifier text diag
99101 , suggestSignature True diag
100− ]
102+ ] ++ concat
103+ [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]]
101104
102105
103−suggestRemoveRedundantImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
104−suggestRemoveRedundantImport contents Diagnostic{_range=_range@Range{..},..}
106+suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
107+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}
105108-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
106109 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
110+ , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
107111 , Just c <- contents
108− , importLine <- textInRange _range c
109− = [( "Remove " <> bindings <> " from import"
110− , [TextEdit _range (dropBindingsFromImportLine (T.splitOn "," bindings) importLine)])]
112+ , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
113+ , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
114+ = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
111115
112116-- File.hs:16:1: warning:
113117-- The import of `Data.List' is redundant
@@ -357,44 +361,29 @@ textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
357361 where
358362 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
359363
360−-- | Drop all occurrences of a binding in an import line.
361−-- Preserves well-formedness but not whitespace between bindings.
362−--
363−-- >>> dropBindingsFromImportLine ["bA", "bC"] "import A(bA, bB,bC ,bA)"
364−-- "import A(bB)"
365−--
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'
371− where
372− bindings = map (wrapOperatorInParens . removeQualified) bindings_
373−
374− (importPre, importRest) = T.breakOn "(" importLine
375−
376− wrapOperatorInParens x = if isAlpha (T.head x) then x else "(" <> x <> ")"
364+-- | Returns the ranges for a binding in an import declaration
365+rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
366+rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
367+ concatMap (map srcSpanToRange . rangesForBinding' b') lies
368+ where
369+ b' = wrapOperatorInParens (unqualify b)
377370
378− removeQualified x = case T.breakOn "." x of
379− (_qualifier, T.uncons -> Just (_, unqualified)) -> unqualified
380− _ -> x
371+ wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
381372
382− importRest' = case T.uncons importRest of
383− Just (_, x) ->
384− T.intercalate ","
385− $ joinCloseParens
386− $ mapMaybe (filtering . T.strip)
387− $ T.splitOn "," x
388− Nothing -> importRest
373+ unqualify x = snd $ breakOnEnd "." x
389374
390− filtering x = case () of
391− () | x `elem` bindings -> Nothing
392− () | x `elem` map (<> ")") bindings -> Just ")"
393− _ -> Just x
375+rangesForBinding _ _ = []
394376
395− joinCloseParens (x : ")" : rest) = (x <> ")") : joinCloseParens rest
396− joinCloseParens (x : rest) = x : joinCloseParens rest
397− joinCloseParens [] = []
377+rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
378+rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
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]
383+ | otherwise =
384+ [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
385+ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
386+rangesForBinding' _ _ = []
398387
399388-- | Extends an import list with a new binding.
400389-- Assumes an import statement of the form:
@@ -428,3 +417,51 @@ setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
428417 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
429418 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
430419 }
420+
421+--------------------------------------------------------------------------------
422+
423+type PositionIndexedString = [(Position, Char)]
424+
425+indexedByPosition :: String -> PositionIndexedString
426+indexedByPosition = unfoldr f . (Position 0 0,) where
427+ f (_, []) = Nothing
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))
430+
431+-- | Returns a tuple (before, contents, after)
432+unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
433+unconsRange Range {..} indexedString = (before, mid, after)
434+ where
435+ (before, rest) = span ((/= _start) . fst) indexedString
436+ (mid, after) = span ((/= _end) . fst) rest
437+
438+stripRange :: Range -> PositionIndexedString -> PositionIndexedString
439+stripRange r s = case unconsRange r s of
440+ (b, _, a) -> b ++ a
441+
442+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
443+extendAllToIncludeCommaIfPossible _ [] = []
444+extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
445+ where
446+ r' = case extendToIncludeCommaIfPossible indexedString r of
447+ [] -> r
448+ r' : _ -> r'
449+ indexedString' = stripRange r' indexedString
450+
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']
457+ ]
458+ ++
459+ -- a, |b|, c ===> a, |b, |c
460+ [ range{_end = end'}
461+ | (_, ',') : rest <- [after']
462+ , let (end', _) : _ = dropWhile (isSpace . snd) rest
463+ ]
464+ where
465+ (before, _, after) = unconsRange range indexedString
466+ after' = dropWhile (isSpace . snd) after
467+ before' = dropWhile (isSpace . snd) (reverse before)