From 597b2d195c93b606f604183c7b4576e2e7935ba1 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 18 Apr 2022 19:12:30 +0100 Subject: [PATCH 1/3] Improve code action that exports a name to reuse export list style --- .../src/Development/IDE/Plugin/CodeAction.hs | 81 ++++++++++++------- ghcide/test/exe/Main.hs | 78 ++++++++++++++++++ 2 files changed, 132 insertions(+), 27 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 1585864279..309c9ce666 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -21,7 +21,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) @@ -37,6 +38,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 @@ -109,7 +111,7 @@ iePluginDescriptor :: PluginId -> PluginDescriptor IdeState iePluginDescriptor plId = let old = mkGhcideCAsPlugin [ - wrap suggestExtendImport + wrap suggestExtendImport , wrap suggestImportDisambiguation , wrap suggestNewOrExtendImportForClassMethod , wrap suggestNewImport @@ -229,8 +231,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) @@ -551,38 +555,61 @@ 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 @@ -605,8 +632,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) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6e8c4d8cef..9a893dccf0 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -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 #-}" From 05245021656559f90b9673ae96fd2ac1a60c5887 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Thu, 21 Apr 2022 01:37:27 +0100 Subject: [PATCH 2/3] Remove outdated comment --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 309c9ce666..2c251b0718 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -5,8 +5,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} --- | Go to the definition of a variable. - module Development.IDE.Plugin.CodeAction ( iePluginDescriptor, From fb3fd13fd0afa812423b1457dc028026bc76efa7 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Thu, 21 Apr 2022 21:11:29 +0100 Subject: [PATCH 3/3] Prefer comparisons on Text to comparisons on String --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 2c251b0718..b0a1143bb6 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -611,13 +611,15 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul _ -> 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 = @@ -1245,7 +1247,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