Delete unused top level binding code action

src/Development/IDE/GHC/Compat.hs

@@ -32,6 +32,8 @@ module Development.IDE.GHC.Compat(
     pattern InstD,
     pattern TyClD,
     pattern ValD,
+    pattern SigD,
+    pattern TypeSig,
     pattern ClassOpSig,
     pattern IEThingAll,
     pattern IEThingWith,
@@ -52,7 +54,7 @@ import Packages
 
 import qualified GHC
 import GHC hiding (
-      ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation
+      ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, SigD, TypeSig, ModLocation
 #if MIN_GHC_API_VERSION(8,6,0)
     , getConArgs
 #endif
@@ -158,6 +160,22 @@ pattern TyClD x <-
     GHC.TyClD x
 #endif
 
+pattern SigD :: Sig p -> HsDecl p
+pattern SigD x <-
+#if MIN_GHC_API_VERSION(8,6,0)
+    GHC.SigD _ x
+#else
+    GHC.SigD x
+#endif
+
+pattern TypeSig :: [Located (IdP p)] -> LHsSigWcType p -> Sig p
+pattern TypeSig x y <-
+#if MIN_GHC_API_VERSION(8,6,0)
+    GHC.TypeSig _ x y
+#else
+    GHC.TypeSig x y
+#endif
+
 pattern ClassOpSig :: Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
 pattern ClassOpSig a b c <-
 #if MIN_GHC_API_VERSION(8,6,0)

src/Development/IDE/Plugin/CodeAction.hs

@@ -158,6 +158,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
     [  suggestNewDefinition ideOptions pm text diag
     ++ suggestRemoveRedundantImport pm text diag
     ++ suggestNewImport packageExports pm diag
+    ++ suggestDeleteTopBinding pm diag
     | Just pm <- [parsedModule]]
 
 
@@ -180,6 +181,30 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmod
         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
     | otherwise = []
 
+suggestDeleteTopBinding :: ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestDeleteTopBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{_range=_range,..}
+-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’
+    | Just [name] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’"
+    , let
+        allTopLevel = filter (isTopLevel . fst) $ map (\(L l b) -> (srcSpanToRange l, b)) hsmodDecls
+        sameName = filter (matchesBindingName (T.unpack name) . snd) allTopLevel
+            = [("Delete ‘" <> name <> "’", flip TextEdit "" . toNextBinding allTopLevel . fst <$> sameName )]
+    | otherwise = []
+    where
+      isTopLevel l = (_character . _start) l == 0
+
+      forwardLines lines r = r {_end = (_end r) {_line = (_line . _end $ r) + lines, _character = 0}}
+
+      toNextBinding bindings r@Range { _end = Position {_line = l} }
+        | Just (Range { _start = Position {_line = l'}}, _) <- find ((> l) . _line . _start . fst) bindings
+        = forwardLines (l' - l) r
+      toNextBinding _ r  = r
+
+      matchesBindingName :: String -> HsDecl GhcPs -> Bool
+      matchesBindingName b (ValD FunBind {fun_id=L _ x}) = showSDocUnsafe (ppr x) == b
+      matchesBindingName b (SigD (TypeSig (L _ x:_) _)) = showSDocUnsafe (ppr x) == b
+      matchesBindingName _ _ = False
+
 suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
 -- File.hs:52:41: error:

test/exe/Main.hs

@@ -476,6 +476,7 @@ codeActionTests = testGroup "code actions"
   , fillTypedHoleTests
   , addSigActionTests
   , insertNewDefinitionTests
+  , deleteUnusedDefinitionTests
   ]
 
 codeLensesTests :: TestTree
@@ -1144,6 +1145,68 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
         ++ txtB')
   ]
 
+
+deleteUnusedDefinitionTests :: TestTree
+deleteUnusedDefinitionTests = testGroup "delete unused definition action"
+  [ testSession "delete unused top level binding" $
+    testFor
+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+               , "module A (some) where"
+               , ""
+               , "f :: Int -> Int"
+               , "f 1 = let a = 1"
+               , "      in a"
+               , "f 2 = 2"
+               , ""
+               , "some = ()"
+               ])
+    (4, 0)
+    "Delete ‘f’"
+    (T.unlines [
+        "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+        , "module A (some) where"
+        , ""
+        , "some = ()"
+        ])
+
+  , testSession "delete unused top level binding defined in infix form" $
+    testFor
+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+               , "module A (some) where"
+               , ""
+               , "myPlus :: Int -> Int -> Int"
+               , "a `myPlus` b = a + b"
+               , ""
+               , "some = ()"
+               ])
+    (4, 2)
+    "Delete ‘myPlus’"
+    (T.unlines [
+        "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+        , "module A (some) where"
+        , ""
+        , "some = ()"
+      ])
+  ]
+  where
+    testFor source pos expectedTitle expectedResult = do
+      docId <- createDoc "A.hs" "haskell" source
+      expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ]
+
+      (action, title) <- extractCodeAction docId "Delete"
+
+      liftIO $ title @?= expectedTitle
+      executeCodeAction action
+      contentAfterAction <- documentContents docId
+      liftIO $ contentAfterAction @?= expectedResult
+
+    extractCodeAction docId actionPrefix = do
+      Just (CACodeAction action@CodeAction { _title = actionTitle })
+                  <- find (\(CACodeAction CodeAction{_title=x}) -> actionPrefix `T.isPrefixOf` x)
+                     <$> getCodeActions docId (R 0 0 0 0)
+      return (action, actionTitle)
+
+
 fixConstructorImportTests :: TestTree
 fixConstructorImportTests = testGroup "fix import actions"
   [ testSession "fix constructor import" $ template