From 8b0d729a32a373d9b6a9318c0be03873a0d00f37 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 11 Oct 2024 12:20:09 +0200 Subject: [PATCH 1/5] Add tests for export unused top binding code action For symbolic pattern synonyms, type families and type classes --- plugins/hls-refactor-plugin/test/Main.hs | 37 ++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 6198d8354e..bdc558a222 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3413,6 +3413,19 @@ exportUnusedTests = testGroup "export unused actions" , "module A (pattern Foo) where" , "pattern Foo a <- (a, _)" ] + , testSession "unused pattern synonym symbol" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern x :+ y = (x, y)" + ] + (R 3 0 3 12) + "Export ‘:+’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern (:+)) where" + , "pattern x :+ y = (x, y)" + ] , testSession "unused data type" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" @@ -3459,6 +3472,19 @@ exportUnusedTests = testGroup "export unused actions" , "module A (Foo) where" , "type family Foo p" ] + , testSession "unused type family symbol" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A () where" + , "type family p &&& q" + ] + (R 3 0 3 10) + "Export ‘&&&’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A (type (&&&)) where" + , "type family p &&& q" + ] , testSession "unused typeclass" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" @@ -3470,6 +3496,17 @@ exportUnusedTests = testGroup "export unused actions" , "module A (Foo(..)) where" , "class Foo a" ] + , testSession "unused typeclass symbol" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "class p &&& q" + ] + (R 2 0 2 10) + "Export ‘&&&’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (type (&&&)(..)) where" + , "class p &&& q" + ] , testSession "infix" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" From a4c15b195af055afa6782ab0b1ffa21f2bcdf6ff Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 11 Oct 2024 12:21:51 +0200 Subject: [PATCH 2/5] Parenthesize symbolic pattern synonyms in add export code action --- .../src/Development/IDE/Plugin/CodeAction.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 367628e48d..e52349b3ac 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -769,7 +769,7 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul printExport :: ExportsAs -> T.Text -> T.Text printExport ExportName x = parenthesizeIfNeeds False x - printExport ExportPattern x = "pattern " <> x + printExport ExportPattern x = "pattern " <> parenthesizeIfNeeds False x printExport ExportFamily x = parenthesizeIfNeeds True x printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" From 6642baa46e45f5b03c4cf676385c6b18d9654b9a Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 11 Oct 2024 12:32:16 +0200 Subject: [PATCH 3/5] Refactor printExport --- .../src/Development/IDE/Plugin/CodeAction.hs | 20 +++++++++---------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index e52349b3ac..c4c2dfe971 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -755,23 +755,21 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul opLetter :: T.Text opLetter = ":!#$%&*+./<=>?@\\^|-~" - parenthesizeIfNeeds :: Bool -> T.Text -> T.Text - parenthesizeIfNeeds needsTypeKeyword 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 = let loc = fmap _start . getLocatedRange $ x in loc >= Just l && loc <= Just r printExport :: ExportsAs -> T.Text -> T.Text - printExport ExportName x = parenthesizeIfNeeds False x - printExport ExportPattern x = "pattern " <> parenthesizeIfNeeds False x - printExport ExportFamily x = parenthesizeIfNeeds True x - printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" + printExport ea name = prefix <> parenthesizedName <> suffix + where + parenthesizedName = if T.any (firstChar ==) opLetter then "(" <> name <> ")" else name + firstChar = T.head name + (prefix, suffix) = case ea of + ExportName -> ("", "") + ExportPattern -> ("pattern ", "") + ExportFamily -> ("type ", "") + ExportAll -> ("type ", "(..)") isTopLevel :: SrcSpan -> Bool isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0 From a8eb8b5ede1abe94c8d320677aca515b6f037ff5 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 11 Oct 2024 12:39:36 +0200 Subject: [PATCH 4/5] Remove superfluous tests --- plugins/hls-refactor-plugin/test/Main.hs | 26 +----------------------- 1 file changed, 1 insertion(+), 25 deletions(-) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index bdc558a222..7144d14f2d 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3413,7 +3413,7 @@ exportUnusedTests = testGroup "export unused actions" , "module A (pattern Foo) where" , "pattern Foo a <- (a, _)" ] - , testSession "unused pattern synonym symbol" $ template + , testSession "unused pattern synonym operator" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "{-# LANGUAGE PatternSynonyms #-}" , "module A () where" @@ -3472,19 +3472,6 @@ exportUnusedTests = testGroup "export unused actions" , "module A (Foo) where" , "type family Foo p" ] - , testSession "unused type family symbol" $ template - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A () where" - , "type family p &&& q" - ] - (R 3 0 3 10) - "Export ‘&&&’" - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A (type (&&&)) where" - , "type family p &&& q" - ] , testSession "unused typeclass" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" @@ -3496,17 +3483,6 @@ exportUnusedTests = testGroup "export unused actions" , "module A (Foo(..)) where" , "class Foo a" ] - , testSession "unused typeclass symbol" $ template - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "class p &&& q" - ] - (R 2 0 2 10) - "Export ‘&&&’" - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (type (&&&)(..)) where" - , "class p &&& q" - ] , testSession "infix" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" From 826391302fc030797354150dcdc8b27de9d15876 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 11 Oct 2024 14:39:45 +0200 Subject: [PATCH 5/5] Revert implementation to correct one --- .../src/Development/IDE/Plugin/CodeAction.hs | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index c4c2dfe971..e52349b3ac 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -755,21 +755,23 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul opLetter :: T.Text opLetter = ":!#$%&*+./<=>?@\\^|-~" + parenthesizeIfNeeds :: Bool -> T.Text -> T.Text + parenthesizeIfNeeds needsTypeKeyword 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 = let loc = fmap _start . getLocatedRange $ x in loc >= Just l && loc <= Just r printExport :: ExportsAs -> T.Text -> T.Text - printExport ea name = prefix <> parenthesizedName <> suffix - where - parenthesizedName = if T.any (firstChar ==) opLetter then "(" <> name <> ")" else name - firstChar = T.head name - (prefix, suffix) = case ea of - ExportName -> ("", "") - ExportPattern -> ("pattern ", "") - ExportFamily -> ("type ", "") - ExportAll -> ("type ", "(..)") + printExport ExportName x = parenthesizeIfNeeds False x + printExport ExportPattern x = "pattern " <> parenthesizeIfNeeds False x + printExport ExportFamily x = parenthesizeIfNeeds True x + printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" isTopLevel :: SrcSpan -> Bool isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0