Skip to content

Commit

Permalink
Improve name export code action (haskell#2847)
Browse files Browse the repository at this point in the history 
* Improve code action that exports a name to reuse export list style

* Remove outdated comment

* Prefer comparisons on Text to comparisons on String

Co-authored-by: Pepe Iborra <[email protected]>
  • Loading branch information
@sergv @pepeiborra @hololeap
2 people authored and hololeap committed Aug 26, 2022
1 parent 8288ca1 commit 432eb88
Show file tree
Hide file tree
Showing 2 changed files with 137 additions and 32 deletions.
91 changes: 59 additions & 32 deletions ghcide/src/Development/IDE/Plugin/CodeAction.hs
View file
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
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

0 comments on commit 432eb88

Please sign in to comment.