Fix for #45 - remove redundant symbols from imports (haskell#290)

* Test for #45

* Remove redundant symbols from imports

Fixes #45

* Update src/Development/IDE/LSP/CodeAction.hs

Co-Authored-By: Andreas Herrmann <[email protected]>

* Apply suggestions from code review

Co-Authored-By: Andreas Herrmann <[email protected]>

* Add regex-tdfa extra deps to ghc-lib build

* Fix for GHC 8.4 (error message prints qualified binding)

GHC ticket #14881 changed this to print identifiers unqualified

* dropBindingsFromImportLine: make total

Co-authored-by: Andreas Herrmann <[email protected]>

ghcide.cabal

@@ -49,6 +49,7 @@ library
         prettyprinter-ansi-terminal,
         prettyprinter-ansi-terminal,
         prettyprinter,
+        regex-tdfa >= 1.3.1.0,
         rope-utf16-splay,
         safe-exceptions,
         shake >= 0.17.5,

src/Development/IDE/LSP/CodeAction.hs

@@ -30,6 +30,8 @@ import Data.Char
 import Data.Maybe
 import Data.List.Extra
 import qualified Data.Text as T
+import Text.Regex.TDFA ((=~), (=~~))
+import Text.Regex.TDFA.Text()
 
 -- | Generate code actions.
 codeAction
@@ -85,14 +87,18 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
 
 suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}
+--     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
+    | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
+    , Just c <- contents
+    , importLine <- textInRange _range c
+    = [( "Remove " <> bindings <> " from import"
+       , [TextEdit _range (dropBindingsFromImportLine (T.splitOn "," bindings) importLine)])]
 
 -- File.hs:16:1: warning:
 --     The import of `Data.List' is redundant
 --       except perhaps to import instances from `Data.List'
 --     To import instances alone, use: import Data.List()
-    | "The import of " `T.isInfixOf` _message
-    || "The qualified import of " `T.isInfixOf` _message
-    , " is redundant" `T.isInfixOf` _message
+    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
 
 -- File.hs:52:41: error:
@@ -293,6 +299,51 @@ textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
     where
       linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
 
+-- | Drop all occurrences of a binding in an import line.
+--   Preserves well-formedness but not whitespace between bindings.
+--
+-- >>> dropBindingsFromImportLine ["bA", "bC"] "import A(bA, bB,bC ,bA)"
+--  "import A(bB)"
+--
+-- >>> dropBindingsFromImportLine ["+"] "import "P" qualified A as B ((+))"
+--  "import "P" qualified A() as B hiding (bB)"
+dropBindingsFromImportLine :: [T.Text] -> T.Text -> T.Text
+dropBindingsFromImportLine bindings_ importLine =
+      importPre <> "(" <> importRest'
+    where
+      bindings = map (wrapOperatorInParens . removeQualified) bindings_
+
+      (importPre, importRest) = T.breakOn "(" importLine
+
+      wrapOperatorInParens x = if isAlpha (T.head x) then x else "(" <> x <> ")"
+
+      removeQualified x = case T.breakOn "." x of
+        (_qualifier, T.uncons -> Just (_, unqualified)) -> unqualified
+        _ -> x
+
+      importRest' = case T.uncons importRest of
+        Just (_, x) ->
+          T.intercalate ","
+            $ joinCloseParens
+            $ mapMaybe (filtering . T.strip)
+            $ T.splitOn "," x
+        Nothing -> importRest
+
+      filtering x = case () of
+        () | x `elem` bindings -> Nothing
+        () | x `elem` map (<> ")") bindings -> Just ")"
+        _                      -> Just x
+
+      joinCloseParens (x : ")" : rest) = (x <> ")") : joinCloseParens rest
+      joinCloseParens (x       : rest) = x : joinCloseParens rest
+      joinCloseParens []               = []
+
+-- | Returns Just (the submatches) for the first capture, or Nothing.
+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
+matchRegex message regex = case message =~~ regex of
+  Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
+  Nothing -> Nothing
+
 setHandlersCodeAction :: PartialHandlers
 setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.codeActionHandler = withResponse RspCodeAction codeAction

stack-ghc-lib.yaml

@@ -9,6 +9,8 @@ extra-deps:
 - ghc-lib-parser-8.8.1
 - ghc-lib-8.8.1
 - fuzzy-0.1.0.0
+- regex-base-0.94.0.0
+- regex-tdfa-1.3.1.0
 nix:
   packages: [zlib]
 flags:

stack.yaml

@@ -7,5 +7,7 @@ extra-deps:
 - lsp-test-0.9.0.0
 - hie-bios-0.3.0
 - fuzzy-0.1.0.0
+- regex-base-0.94.0.0
+- regex-tdfa-1.3.1.0
 nix:
   packages: [zlib]

stack84.yaml

@@ -12,6 +12,8 @@ extra-deps:
 - js-dgtable-0.5.2
 - hie-bios-0.3.0
 - fuzzy-0.1.0.0
+- regex-base-0.94.0.0
+- regex-tdfa-1.3.1.0
 nix:
   packages: [zlib]
 allow-newer: true

stack88.yaml

@@ -7,6 +7,8 @@ extra-deps:
 - lsp-test-0.9.0.0
 - hie-bios-0.3.0
 - fuzzy-0.1.0.0
+- regex-base-0.94.0.0
+- regex-tdfa-1.3.1.0
 allow-newer: true
 nix:
   packages: [zlib]

test/exe/Main.hs

@@ -594,6 +594,66 @@ removeImportTests = testGroup "remove import actions"
             , "stuffB = 123"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "redundant binding" $ do
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "stuffA = False"
+            , "stuffB :: Integer"
+            , "stuffB = 123"
+            ]
+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA
+      let contentB = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (stuffA, stuffB)"
+            , "main = print stuffB"
+            ]
+      docB <- openDoc' "ModuleB.hs" "haskell" contentB
+      _ <- waitForDiagnostics
+      [CACodeAction action@CodeAction { _title = actionTitle }]
+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
+      liftIO $ "Remove stuffA from import" @=? actionTitle
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      let expectedContentAfterAction = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (stuffB)"
+            , "main = print stuffB"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "redundant symbol binding" $ do
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "a !! b = a"
+            , "stuffB :: Integer"
+            , "stuffB = 123"
+            ]
+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA
+      let contentB = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import qualified ModuleA as A ((!!), stuffB, (!!))"
+            , "main = print A.stuffB"
+            ]
+      docB <- openDoc' "ModuleB.hs" "haskell" contentB
+      _ <- waitForDiagnostics
+      [CACodeAction action@CodeAction { _title = actionTitle }]
+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
+#if MIN_GHC_API_VERSION(8,6,0)
+      liftIO $ "Remove !! from import" @=? actionTitle
+#else
+      liftIO $ "Remove A.!! from import" @=? actionTitle
+#endif
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      let expectedContentAfterAction = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import qualified ModuleA as A (stuffB)"
+            , "main = print A.stuffB"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
   ]
 
 importRenameActionTests :: TestTree