Fix redundant import code action corner cases (#433)

- Redundant "All" imports, e.g. Maybe(..)
 - Redundant datatype plus constructors, e.g. Maybe(Just)

Fixes #352

ghcide.cabal

@@ -138,6 +138,7 @@ library
         Development.IDE.Spans.Calculate
         Development.IDE.Spans.Documentation
         Development.IDE.Spans.Type
+        Development.IDE.Plugin.CodeAction.PositionIndexed
         Development.IDE.Plugin.Completions.Logic
         Development.IDE.Plugin.Completions.Types
     ghc-options: -Wall -Wno-name-shadowing

src/Development/IDE/GHC/Compat.hs

@@ -22,6 +22,7 @@ module Development.IDE.GHC.Compat(
     pattern TyClD,
     pattern ValD,
     pattern ClassOpSig,
+    pattern IEThingAll,
     pattern IEThingWith,
     GHC.ModLocation,
     pattern ModLocation,
@@ -34,7 +35,7 @@ import DynFlags
 import FieldLabel
 
 import qualified GHC
-import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD, ModLocation)
+import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)
 
 #if MIN_GHC_API_VERSION(8,8,0)
 import HieAst
@@ -147,3 +148,11 @@ pattern ModLocation a b c <-
 #else
     GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
 #endif
+
+pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass
+pattern IEThingAll a <-
+#if MIN_GHC_API_VERSION(8,6,0)
+    GHC.IEThingAll _ a
+#else
+    GHC.IEThingAll a
+#endif

src/Development/IDE/Plugin/CodeAction.hs

@@ -19,6 +19,7 @@ import Development.IDE.Core.Shake
 import Development.IDE.GHC.Error
 import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
+import Development.IDE.Plugin.CodeAction.PositionIndexed
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import qualified Data.HashMap.Strict as Map
@@ -130,6 +131,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmod
     , Just c <- contents
     , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
     , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
+    , not (null ranges')
     = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
 
 -- File.hs:16:1: warning:
@@ -424,7 +426,7 @@ rangesForBinding _ _ = []
 rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
 rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
 rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
-rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]
 rangesForBinding' b (L l (IEThingWith thing _  inners labels))
     | showSDocUnsafe (ppr thing) == b = [l]
     | otherwise =
@@ -464,52 +466,4 @@ filterNewlines :: T.Text -> T.Text
 filterNewlines = T.concat  . T.lines
 
 unifySpaces :: T.Text -> T.Text
-unifySpaces    = T.unwords . T.words
-
---------------------------------------------------------------------------------
-
-type PositionIndexedString = [(Position, Char)]
-
-indexedByPosition :: String -> PositionIndexedString
-indexedByPosition = unfoldr f . (Position 0 0,) where
-  f (_, []) = Nothing
-  f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))
-  f (p@(Position l c),    x : rest) = Just ((p,   x), (Position l (c+1), rest))
-
--- | Returns a tuple (before, contents, after)
-unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
-unconsRange Range {..} indexedString = (before, mid, after)
-  where
-    (before, rest) = span ((/= _start) . fst) indexedString
-    (mid, after) = span ((/= _end) . fst) rest
-
-stripRange :: Range -> PositionIndexedString -> PositionIndexedString
-stripRange r s = case unconsRange r s of
-  (b, _, a) -> b ++ a
-
-extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
-extendAllToIncludeCommaIfPossible _             [] =  []
-extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
-  where
-    r' = case extendToIncludeCommaIfPossible indexedString r of
-          [] -> r
-          r' : _ -> r'
-    indexedString' = stripRange r' indexedString
-
--- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas
-extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
-extendToIncludeCommaIfPossible indexedString range =
-    -- a, |b|, c ===> a|, b|, c
-    [ range{_start = start'}
-    | (start', ',') : _ <- [before']
-    ]
-    ++
-    -- a, |b|, c ===> a, |b, |c
-    [ range{_end = end'}
-    |  (_, ',') : rest <- [after']
-    , let (end', _) : _ = dropWhile (isSpace . snd) rest
-    ]
-  where
-    (before, _, after) = unconsRange range indexedString
-    after' = dropWhile (isSpace . snd) after
-    before' = dropWhile (isSpace . snd) (reverse before)
+unifySpaces    = T.unwords . T.words

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs

@@ -0,0 +1,112 @@
+-- | Position indexed streams of characters
+module Development.IDE.Plugin.CodeAction.PositionIndexed
+  ( PositionIndexed
+  , PositionIndexedString
+  , indexedByPosition
+  , indexedByPositionStartingFrom
+  , extendAllToIncludeCommaIfPossible
+  , mergeRanges
+  )
+where
+
+import           Data.Char
+import           Data.List
+import           Language.Haskell.LSP.Types
+
+type PositionIndexed a = [(Position, a)]
+
+type PositionIndexedString = PositionIndexed Char
+
+-- | Add position indexing to a String.
+--
+--   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡
+--   >   [ ((0,0),'h')
+--   >   , ((0,1),'e')
+--   >   , ((0,2),'y')
+--   >   , ((0,3),'\n')
+--   >   , ((1,0),' ')
+--   >   , ((1,1),'h')
+--   >   , ((1,2),'o')
+--   >   ]
+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString
+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where
+  f (_, []) = Nothing
+  f (p@(Position l _), '\n' : rest) =
+    Just ((p, '\n'), (Position (l + 1) 0, rest))
+  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))
+
+-- | Add position indexing to a String.
+--
+--   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
+indexedByPosition :: String -> PositionIndexedString
+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
+
+-- | Returns a tuple (before, contents, after) if the range is present.
+--   The range is present only if both its start and end positions are present
+unconsRange
+  :: Range
+  -> PositionIndexed a
+  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)
+unconsRange Range {..} indexedString
+  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString
+  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest
+  = Just (before, mid, after)
+  | otherwise
+  = Nothing
+
+-- | Strips out all the positions included in the range.
+--   Returns 'Nothing' if the start or end of the range are not included in the input.
+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)
+stripRange r s = case unconsRange r s of
+  Just (b, _, a) -> Just (b ++ a)
+  Nothing        -> Nothing
+
+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.
+--   Assumes input ranges are sorted on the start positions.
+mergeRanges :: [Range] -> [Range]
+mergeRanges (r : r' : rest)
+  |
+    -- r' is contained in r
+    _end r > _end r'   = mergeRanges (r : rest)
+  |
+    -- r and r' are overlapping
+    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)
+
+  | otherwise          = r : mergeRanges (r' : rest)
+mergeRanges other = other
+
+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas
+--
+-- @
+--   a, |b|,  c  ===> a|, b|,  c
+--   a,  b,  |c| ===> a,  b|,  c|
+--   a, |b|, |c| ===> a|, b||, c|
+-- @
+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
+extendAllToIncludeCommaIfPossible indexedString =
+  mergeRanges . go indexedString . sortOn _start
+ where
+  go _ [] = []
+  go input (r : rr)
+    | r' : _ <- extendToIncludeCommaIfPossible input r
+    , Just input' <- stripRange r' input
+    = r' : go input' rr
+    | otherwise
+    = go input rr
+
+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
+extendToIncludeCommaIfPossible indexedString range
+  | Just (before, _, after) <- unconsRange range indexedString
+  , after' <- dropWhile (isSpace . snd) after
+  , before' <- dropWhile (isSpace . snd) (reverse before)
+  =
+    -- a, |b|, c ===> a|, b|, c
+    [ range { _start = start' } | (start', ',') : _ <- [before'] ]
+    ++
+    -- a, |b|, c ===> a, |b, |c
+    [ range { _end = end' }
+    | (_, ',') : rest <- [after']
+    , let (end', _) : _ = dropWhile (isSpace . snd) rest
+    ]
+  | otherwise
+  = [range]

test/exe/Main.hs

@@ -669,10 +669,11 @@ removeImportTests = testGroup "remove import actions"
             , "main = print stuffB"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "redundant symbol binding" $ do
+  , testSession "redundant operator" $ do
       let contentA = T.unlines
             [ "module ModuleA where"
             , "a !! b = a"
+            , "a <?> b = a"
             , "stuffB :: Integer"
             , "stuffB = 123"
             ]
@@ -680,7 +681,7 @@ removeImportTests = testGroup "remove import actions"
       let contentB = T.unlines
             [ "{-# OPTIONS_GHC -Wunused-imports #-}"
             , "module ModuleB where"
-            , "import qualified ModuleA as A ((!!), stuffB, (!!))"
+            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
             , "main = print A.stuffB"
             ]
       docB <- openDoc' "ModuleB.hs" "haskell" contentB
@@ -688,9 +689,9 @@ removeImportTests = testGroup "remove import actions"
       [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
+      liftIO $ "Remove !!, <?> from import" @=? actionTitle
 #else
-      liftIO $ "Remove A.!! from import" @=? actionTitle
+      liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
 #endif
       executeCodeAction action
       contentAfterAction <- documentContents docB
@@ -701,7 +702,7 @@ removeImportTests = testGroup "remove import actions"
             , "main = print A.stuffB"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do
+  , testSession "redundant all import" $ do
       let contentA = T.unlines
             [ "module ModuleA where"
             , "data A = A"
@@ -729,6 +730,33 @@ removeImportTests = testGroup "remove import actions"
             , "main = print stuffB"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "redundant constructor import" $ do
+      let contentA = T.unlines
+            [ "module ModuleA where"
+            , "data D = A | B"
+            , "data E = F"
+            ]
+      _docA <- openDoc' "ModuleA.hs" "haskell" contentA
+      let contentB = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (D(A,B), E(F))"
+            , "main = B"
+            ]
+      docB <- openDoc' "ModuleB.hs" "haskell" contentB
+      _ <- waitForDiagnostics
+      [CACodeAction action@CodeAction { _title = actionTitle }]
+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
+      liftIO $ "Remove A, E, F from import" @=? actionTitle
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      let expectedContentAfterAction = T.unlines
+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
+            , "module ModuleB where"
+            , "import ModuleA (D(B))"
+            , "main = B"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
   ]
 
 extendImportTests :: TestTree