Improve name export code action (#2847)

* 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]>

Author: sergv

Diff for: 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,
@@ -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)
@@ -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
@@ -107,7 +107,7 @@ iePluginDescriptor :: PluginId -> PluginDescriptor IdeState
 iePluginDescriptor plId =
   let old =
         mkGhcideCAsPlugin [
-           wrap suggestExtendImport
+            wrap suggestExtendImport
           , wrap suggestImportDisambiguation
           , wrap suggestNewOrExtendImportForClassMethod
           , wrap suggestNewImport
@@ -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)
 
@@ -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 =
@@ -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)
@@ -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

Diff for: 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 #-}"