Skip to content

Commit

Permalink
Codeaction for exporting unused top-level bindings (haskell/ghcide#711)
Browse files Browse the repository at this point in the history 
* Add PatSynBind to GHC.Compat

* Tests for "export unused top level binding" codeaction

* Add "export unused top-level binding" codeaction

* exportUnusedTests refactored

* Fix export unused codeaction

* NFC: remove unused import

* hlint

* add exports to the end of list instead

* handle the case where last export end with comma
  • Loading branch information
@sureyeaah
sureyeaah authored Jul 27, 2020
1 parent c8fed9b commit 7c35212
Show file tree
Hide file tree
Showing 3 changed files with 267 additions and 2 deletions.
9 changes: 9 additions & 0 deletions ghcide/src/Development/IDE/GHC/Compat.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,7 @@ module Development.IDE.GHC.Compat(
pattern IEThingAll,
pattern IEThingWith,
pattern VarPat,
pattern PatSynBind,
GHC.ModLocation,
Module.addBootSuffix,
pattern ModLocation,
Expand Down Expand Up @@ -90,6 +91,7 @@ import GHC hiding (
VarPat,
ModLocation,
HasSrcSpan,
PatSynBind,
lookupName,
getLoc
#if MIN_GHC_API_VERSION(8,6,0)
Expand Down Expand Up @@ -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 =
Expand Down
59 changes: 58 additions & 1 deletion ghcide/src/Development/IDE/Plugin/CodeAction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,6 @@ module Development.IDE.Plugin.CodeAction
, executeAddSignatureCommand
) where

import Language.Haskell.LSP.Types
import Control.Monad (join, guard)
import Development.IDE.Plugin
import Development.IDE.GHC.Compat
Expand All @@ -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
Expand Down Expand Up @@ -155,6 +155,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
++ suggestRemoveRedundantImport pm text diag
++ suggestNewImport packageExports pm diag
++ suggestDeleteTopBinding pm diag
++ suggestExportUnusedTopBinding text pm diag
| Just pm <- [parsedModule]]


Expand Down Expand Up @@ -204,6 +205,62 @@ 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 :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
suggestExportUnusedTopBinding srcOpt 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 source <- srcOpt
, 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 <- _end . getLocatedRange <$> hsmodExports
, Just needComma <- needsComma source <$> hsmodExports
, let exportName = (if needComma then "," else "") <> printExport exportType name
insertPos = pos {_character = pred $ _character pos}
= [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]
| otherwise = []
where
-- we get the last export and the closing bracket and check for comma in that range
needsComma :: T.Text -> Located [LIE GhcPs] -> Bool
needsComma _ (L _ []) = False
needsComma source x@(L _ exports) =
let closeParan = _end $ getLocatedRange x
lastExport = _end . getLocatedRange $ last exports
in not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source

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,..}
Expand Down
201 changes: 200 additions & 1 deletion ghcide/test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -488,6 +488,7 @@ codeActionTests = testGroup "code actions"
, addFunctionConstraintTests
, removeRedundantConstraintsTests
, addTypeAnnotationsToLiteralsTest
, exportUnusedTests
]

codeLensesTests :: TestTree
Expand Down Expand Up @@ -1657,6 +1658,204 @@ 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 3 0 3 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 (foo,bar) 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"
, " ("
, " foo,bar) where"
, "foo = id"
, "bar = foo"])
, testSession "export list ends in comma" $ template
(T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " (foo,"
, " ) where"
, "foo = id"
, "bar = foo"])
(R 4 0 4 3)
"Export ‘bar’"
(Just $ T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " (foo,"
, " bar) 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 #-}"
Expand Down Expand Up @@ -2806,7 +3005,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 =
Expand Down

0 comments on commit 7c35212

Please sign in to comment.