Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Improve name export code action #2847

Merged
merged 5 commits into from
Apr 30, 2022
Merged

Improve name export code action #2847

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
597b2d1
Improve code action that exports a name to reuse export list style
sergv Apr 18, 2022
0524502
Remove outdated comment
sergv Apr 21, 2022
fb3fd13
Prefer comparisons on Text to comparisons on String
sergv Apr 21, 2022
12aa749
Merge branch 'master' into imporove-name-export
pepeiborra Apr 24, 2022
312b3c0
Merge branch 'master' into imporove-name-export
pepeiborra Apr 29, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
91 changes: 59 additions & 32 deletions ghcide/src/Development/IDE/Plugin/CodeAction.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,8 +5,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}

-- | Go to the definition of a variable.

module Development.IDE.Plugin.CodeAction
(
iePluginDescriptor,
Expand All @@ -21,7 +19,8 @@ module Development.IDE.Plugin.CodeAction

import Control.Applicative ((<|>))
import Control.Arrow (second,
(>>>))
(>>>),
(&&&))
import Control.Concurrent.STM.Stats (atomically)
import Control.Monad (guard, join,
msum)
Expand All @@ -37,6 +36,7 @@ import Data.List.NonEmpty (NonEmpty ((:
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe
import Data.Ord (comparing)
import qualified Data.Rope.UTF16 as Rope
import qualified Data.Set as S
import qualified Data.Text as T
Expand Down Expand Up @@ -107,7 +107,7 @@ iePluginDescriptor :: PluginId -> PluginDescriptor IdeState
iePluginDescriptor plId =
let old =
mkGhcideCAsPlugin [
wrap suggestExtendImport
wrap suggestExtendImport
, wrap suggestImportDisambiguation
, wrap suggestNewOrExtendImportForClassMethod
, wrap suggestNewImport
Expand Down Expand Up @@ -227,8 +227,10 @@ findInstanceHead df instanceHead decls =

#if MIN_VERSION_ghc(9,2,0)
findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e)
#elif MIN_VERSION_ghc(8,10,0)
findDeclContainingLoc :: Foldable t => Position -> t (GenLocated SrcSpan e) -> Maybe (GenLocated SrcSpan e)
#else
-- TODO populate this type signature for GHC versions <9.2
-- TODO populate this type signature for GHC versions <8.10
#endif
findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)

Expand Down Expand Up @@ -549,48 +551,73 @@ suggestDeleteUnusedBinding
data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll
deriving (Eq)

getLocatedRange :: Located a -> Maybe Range
getLocatedRange :: HasSrcSpan a => a -> Maybe Range
getLocatedRange = srcSpanToRange . getLoc

suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)]
suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (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] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"
<|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"
<|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"
, Just (exportType, _) <- find (matchWithDiagnostic _range . snd)
. mapMaybe
(\(L (locA -> l) b) -> if maybe False isTopLevel $ srcSpanToRange l
then exportsAs b else Nothing)
$ hsmodDecls
, Just pos <- (fmap _end . getLocatedRange) . reLoc =<< hsmodExports
, Just needComma <- needsComma source <$> fmap reLoc hsmodExports
, let exportName = (if needComma then ", " else "") <> printExport exportType name
insertPos = pos {_character = pred $ _character pos}
= [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)]
| otherwise = []
, Just [_, name] <-
matchRegexUnifySpaces
_message
".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’"
, Just (exportType, _) <-
find (matchWithDiagnostic _range . snd)
. mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing)
$ hsmodDecls
, Just exports <- fmap (fmap reLoc) . reLoc <$> hsmodExports
, Just exportsEndPos <- _end <$> getLocatedRange exports
, let name' = printExport exportType name
sep = exportSep source $ map getLocatedRange <$> exports
exportName = case sep of
Nothing -> (if needsComma source exports then ", " else "") <> name'
Just s -> s <> name'
exportsEndPos' = exportsEndPos { _character = pred $ _character exportsEndPos }
insertPos = fromMaybe exportsEndPos' $ case (sep, unLoc exports) of
(Just _, exports'@(_:_)) -> fmap _end . getLocatedRange $ last exports'
_ -> Nothing
= Just ("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)
| otherwise = Nothing
where
-- we get the last export and the closing bracket and check for comma in that range
needsComma :: T.Text -> Located [LIE GhcPs] -> Bool
exportSep :: T.Text -> Located [Maybe Range] -> Maybe T.Text
exportSep src (L (RealSrcSpan _ _) xs@(_ : tl@(_ : _))) =
case mapMaybe (\(e, s) -> (,) <$> e <*> s) $ zip (fmap _end <$> xs) (fmap _start <$> tl) of
[] -> Nothing
bounds -> Just smallestSep
where
smallestSep
= snd
$ minimumBy (comparing fst)
$ map (T.length &&& id)
$ nubOrd
$ map (\(prevEnd, nextStart) -> textInRange (Range prevEnd nextStart) src) bounds
exportSep _ _ = Nothing

-- We get the last export and the closing bracket and check for comma in that range.
needsComma :: T.Text -> Located [Located (IE GhcPs)] -> Bool
needsComma _ (L _ []) = False
needsComma source (L (RealSrcSpan l _) exports) =
let closeParan = _end $ realSrcSpanToRange l
lastExport = fmap _end . getLocatedRange $ last $ fmap reLoc exports
in case lastExport of
Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source
let closeParen = _end $ realSrcSpanToRange l
lastExport = fmap _end . getLocatedRange $ last exports
in
case lastExport of
Just lastExport ->
not $ T.any (== ',') $ textInRange (Range lastExport closeParen) source
_ -> False
needsComma _ _ = False

opLetter :: String
opLetter :: T.Text
opLetter = ":!#$%&*+./<=>?@\\^|-~"

parenthesizeIfNeeds :: Bool -> T.Text -> T.Text
parenthesizeIfNeeds needsTypeKeyword x
| T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"
| T.any (c ==) opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <> ")"
| otherwise = x
where
c = T.head x

matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool
matchWithDiagnostic Range{_start=l,_end=r} x =
Expand All @@ -603,8 +630,8 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul
printExport ExportFamily x = parenthesizeIfNeeds True x
printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)"

isTopLevel :: Range -> Bool
isTopLevel l = (_character . _start) l == 0
isTopLevel :: SrcSpan -> Bool
isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0

exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs))
exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, reLoc fun_id)
Expand Down Expand Up @@ -1218,7 +1245,7 @@ removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..}
= [(actionTitle redundantConstraintList typeSignatureName, rewrite)]
| otherwise = []
where
toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list)
toRemove df list a = T.pack (showSDoc df (ppr a)) `elem` list

parseConstraints :: T.Text -> [T.Text]
parseConstraints t = t
Expand Down
78 changes: 78 additions & 0 deletions ghcide/test/exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3653,6 +3653,84 @@ exportUnusedTests = testGroup "export unused actions"
, " bar) where"
, "foo = id"
, "bar = foo"])
, testSession "style of multiple exports is preserved 1" $ template
(T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo"
, " , bar"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
])
(R 7 0 7 3)
"Export ‘baz’"
(Just $ T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo"
, " , bar"
, " , baz"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
])
, testSession "style of multiple exports is preserved 2" $ template
(T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo,"
, " bar"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
])
(R 7 0 7 3)
"Export ‘baz’"
(Just $ T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo,"
, " bar,"
, " baz"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
])
, testSession "style of multiple exports is preserved and selects smallest export separator" $ template
(T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo"
, " , bar"
, " -- * For testing"
, " , baz"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
, "quux = bar"
])
(R 10 0 10 4)
"Export ‘quux’"
(Just $ T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
, "module A"
, " ( foo"
, " , bar"
, " -- * For testing"
, " , baz"
, " , quux"
, " ) where"
, "foo = id"
, "bar = foo"
, "baz = bar"
, "quux = bar"
])
, testSession "unused pattern synonym" $ template
(T.unlines
[ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
Expand Down