Codeaction for exporting unused top-level bindings

src/Development/IDE/GHC/Compat.hs

@@ -41,6 +41,7 @@ module Development.IDE.GHC.Compat(
     pattern IEThingAll,
     pattern IEThingWith,
     pattern VarPat,
+    pattern PatSynBind,
     GHC.ModLocation,
     Module.addBootSuffix,
     pattern ModLocation,
@@ -90,6 +91,7 @@ import GHC hiding (
       VarPat,
       ModLocation,
       HasSrcSpan,
+      PatSynBind,
       lookupName,
       getLoc
 #if MIN_GHC_API_VERSION(8,6,0)
@@ -274,6 +276,13 @@ pattern VarPat x <-
     GHC.VarPat x
 #endif
 
+pattern PatSynBind :: GHC.PatSynBind p p -> HsBind p
+pattern PatSynBind x <-
+#if MIN_GHC_API_VERSION(8,6,0)
+    GHC.PatSynBind _ x
+#else
+    GHC.PatSynBind x
+#endif
 
 setHieDir :: FilePath -> DynFlags -> DynFlags
 setHieDir _f d =

src/Development/IDE/Plugin/CodeAction.hs

@@ -17,7 +17,6 @@ module Development.IDE.Plugin.CodeAction
     , executeAddSignatureCommand
     ) where
 
-import           Language.Haskell.LSP.Types
 import Control.Monad (join)
 import Development.IDE.Plugin
 import Development.IDE.GHC.Compat
@@ -38,6 +37,7 @@ import qualified Data.HashMap.Strict as Map
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
 import qualified Data.Rope.UTF16 as Rope
 import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
 import Data.Char
@@ -153,6 +153,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
     ++ suggestRemoveRedundantImport pm text diag
     ++ suggestNewImport packageExports pm diag
     ++ suggestDeleteTopBinding pm diag
+    ++ suggestExportUnusedTopBinding pm diag
     | Just pm <- [parsedModule]]
 
 
@@ -202,6 +203,53 @@ suggestDeleteTopBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}
       matchesBindingName b (SigD (TypeSig (L _ x:_) _)) = showSDocUnsafe (ppr x) == b
       matchesBindingName _ _ = False
 
+data ExportsAs = ExportName | ExportPattern | ExportAll
+  deriving (Eq)
+
+suggestExportUnusedTopBinding :: ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestExportUnusedTopBinding ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}
+-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’
+-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’
+-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’
+  | Just [name] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’"
+                   <|> matchRegex _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"
+                   <|> matchRegex _message ".*Defined but not used: data constructor ‘([^ ]+)’"
+  , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)
+                            . mapMaybe
+                                (\(L l b) -> if isTopLevel $ srcSpanToRange l
+                                                then exportsAs b else Nothing)
+                            $ hsmodDecls
+  , Just pos <- _start . getLocatedRange <$> hsmodExports
+  , Just needComma <- not . null . unLoc <$> hsmodExports
+  , let exportName = printExport exportType name <> (if needComma then "," else "")
+        insertPos = pos {_character = succ $ _character pos}
+  = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]
+  | otherwise = []
+  where
+    getLocatedRange :: Located a -> Range
+    getLocatedRange = srcSpanToRange . getLoc
+
+    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool
+    matchWithDiagnostic Range{_start=l,_end=r} x =
+      let loc = _start . getLocatedRange $ x
+       in loc >= l && loc <= r
+
+    printExport :: ExportsAs -> T.Text -> T.Text
+    printExport ExportName x = x
+    printExport ExportPattern x = "pattern " <> x
+    printExport ExportAll x = x <> "(..)"
+
+    isTopLevel :: Range -> Bool
+    isTopLevel l = (_character . _start) l == 0
+
+    exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p))
+    exportsAs (ValD FunBind {fun_id})          = Just (ExportName, fun_id)
+    exportsAs (ValD (PatSynBind PSB {psb_id})) = Just (ExportPattern, psb_id)
+    exportsAs (TyClD SynDecl{tcdLName})      = Just (ExportName, tcdLName)
+    exportsAs (TyClD DataDecl{tcdLName})     = Just (ExportAll, tcdLName)
+    exportsAs (TyClD ClassDecl{tcdLName})    = Just (ExportAll, tcdLName)
+    exportsAs (TyClD FamDecl{tcdFam})        = Just (ExportAll, fdLName tcdFam)
+    exportsAs _                                = Nothing
 
 suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}

test/exe/Main.hs

@@ -487,6 +487,7 @@ codeActionTests = testGroup "code actions"
   , addInstanceConstraintTests
   , addFunctionConstraintTests
   , addTypeAnnotationsToLiteralsTest
+  , exportUnusedTests
   ]
 
 codeLensesTests :: TestTree
@@ -1581,6 +1582,185 @@ addSigActionTests = let
     , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
     ]
 
+exportUnusedTests :: TestTree
+exportUnusedTests = testGroup "export unused actions"
+  [ testGroup "don't want suggestion"
+    [ testSession "implicit exports" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+              , "{-# OPTIONS_GHC -Wmissing-signatures #-}"
+              , "module A where"
+              , "foo = id"])
+        (R 3 0 3 3)
+        "Export ‘foo’"
+        Nothing -- codeaction should not be available
+    , testSession "not top-level" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "{-# OPTIONS_GHC -Wunused-binds #-}" 
+              , "module A (foo,bar) where"
+              , "foo = ()"
+              , "  where bar = ()"
+              , "bar = ()"])
+        (R 2 0 2 11)
+        "Export ‘bar’"
+        Nothing
+    , testSession "type is exported but not the constructor of same name" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+              , "module A (Foo) where"
+              , "data Foo = Foo"])
+        (R 2 0 2 8)
+        "Export ‘Foo’"
+        Nothing -- codeaction should not be available
+    , testSession "unused data field" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+              , "module A (Foo(Foo)) where"
+              , "data Foo = Foo {foo :: ()}"])
+        (R 2 0 2 20)
+        "Export ‘foo’"
+        Nothing -- codeaction should not be available
+    ]
+  , testGroup "want suggestion"
+    [ testSession "empty exports" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+              , "module A () where"
+              , "foo = id"])
+        (R 2 0 2 3)
+        "Export ‘foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (foo) where"
+              , "foo = id"])
+    , testSession "single line explicit exports" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (foo) where"
+              , "foo = id"
+              , "bar = foo"])
+        (R 3 0 3 3)
+        "Export ‘bar’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (bar,foo) where"
+              , "foo = id"
+              , "bar = foo"])
+    , testSession "multi line explicit exports" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A"
+              , "  ("
+              , "    foo) where"
+              , "foo = id"
+              , "bar = foo"])
+        (R 5 0 5 3)
+        "Export ‘bar’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A"
+              , "  (bar,"
+              , "    foo) where"
+              , "foo = id"
+              , "bar = foo"])
+    , testSession "unused pattern synonym" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "{-# LANGUAGE PatternSynonyms #-}" 
+              , "module A () where"
+              , "pattern Foo a <- (a, _)"])
+        (R 3 0 3 10)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "{-# LANGUAGE PatternSynonyms #-}" 
+              , "module A (pattern Foo) where"
+              , "pattern Foo a <- (a, _)"])
+    , testSession "unused data type" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A () where"
+              , "data Foo = Foo"])
+        (R 2 0 2 7)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (Foo(..)) where"
+              , "data Foo = Foo"])
+    , testSession "unused newtype" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A () where"
+              , "newtype Foo = Foo ()"])
+        (R 2 0 2 10)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (Foo(..)) where"
+              , "newtype Foo = Foo ()"])
+    , testSession "unused type synonym" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A () where"
+              , "type Foo = ()"])
+        (R 2 0 2 7)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (Foo) where"
+              , "type Foo = ()"])
+    , testSession "unused type family" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "{-# LANGUAGE TypeFamilies #-}" 
+              , "module A () where"
+              , "type family Foo p"])
+        (R 3 0 3 15)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "{-# LANGUAGE TypeFamilies #-}" 
+              , "module A (Foo(..)) where"
+              , "type family Foo p"])
+    , testSession "unused typeclass" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A () where"
+              , "class Foo a"])
+        (R 2 0 2 8)
+        "Export ‘Foo’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (Foo(..)) where"
+              , "class Foo a"])
+    , testSession "infix" $ template
+        (T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A () where"
+              , "a `f` b = ()"])
+        (R 2 0 2 11)
+        "Export ‘f’"
+        (Just $ T.unlines
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              , "module A (f) where"
+              , "a `f` b = ()"])
+    ]
+  ]
+    where
+      template initialContent range expectedAction expectedContents = do
+        doc <- createDoc "A.hs" "haskell" initialContent
+        _ <- waitForDiagnostics
+        actions <- getCodeActions doc range
+        case expectedContents of
+          Just content -> do
+            action <- liftIO $ pickActionWithTitle expectedAction actions
+            executeCodeAction action
+            contentAfterAction <- documentContents doc
+            liftIO $ content @=? contentAfterAction
+          Nothing ->
+            liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= []
+
 addSigLensesTests :: TestTree
 addSigLensesTests = let
   missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
@@ -2728,7 +2908,7 @@ testSessionWait name = testSession name .
 
 pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
 pickActionWithTitle title actions = do
-  assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
+  assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)
   return $ head matches
   where
     titles =