Skip to content

Commit 6e76fce

Browse files
batkotJuly541
batkot
and
July541
authored
hls-class-plugin - Add placeholders for all class methods (#3394)
* #3017 WIP: Add Action for all missing class methods * #3017 WIP: Filter out equivalent suggestions * #3017 Fix CodeAction title, adjust tests * #3017 Rename functions * #3017 Update demo gifs * 3017 Stylish-haskell Co-authored-by: Lei Zhu <julytreee@gmail.com>
1 parent 472947c commit 6e76fce

File tree

9 files changed

+102
-38
lines changed

9 files changed

+102
-38
lines changed

‎plugins/hls-class-plugin/README.md‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,8 @@
33
The class plugin provides handy operations about class, includes:
44

55
1. Code action to add minimal class definition methods.
6-
2. Type lens about missing type signatures for instance methods.
6+
2. Code action to all missing class methods.
7+
3. Type lens about missing type signatures for instance methods.
78

89
## Demo
910

‎plugins/hls-class-plugin/codeactions.gif‎

-742 KB
Loading

‎plugins/hls-class-plugin/codelens.gif‎

-157 KB
Loading

‎plugins/hls-class-plugin/hls-class-plugin.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -77,3 +77,4 @@ test-suite tests
7777
, hls-test-utils ^>=1.5
7878
, lens
7979
, lsp-types
80+
, text

‎plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs‎

Lines changed: 48 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,10 @@ import Control.Monad.Trans.Class (lift)
1313
import Control.Monad.Trans.Except (ExceptT, throwE)
1414
import Control.Monad.Trans.Maybe
1515
import Data.Aeson
16+
import Data.Bifunctor (second)
1617
import Data.Either.Extra (rights)
1718
import Data.List
19+
import Data.List.Extra (nubOrdOn)
1820
import qualified Data.Map.Strict as Map
1921
import Data.Maybe (isNothing, listToMaybe,
2022
mapMaybe)
@@ -113,30 +115,31 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
113115
logWith recorder Info (LogImplementedMethods cls implemented)
114116
pure
115117
$ concatMap mkAction
116-
$ fmap (filter (\(bind, _) -> bind `notElem` implemented))
117-
$ minDefToMethodGroups range sigs
118-
$ classMinimalDef cls
118+
$ nubOrdOn snd
119+
$ filter ((/=) mempty . snd)
120+
$ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
121+
$ mkMethodGroups range sigs cls
119122
where
120123
range = diag ^. J.range
121124

122-
mkAction :: [(T.Text, T.Text)] -> [Command |? CodeAction]
123-
mkAction methodGroup
125+
mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
126+
mkMethodGroups range sigs cls = minimalDef <> [allClassMethods]
127+
where
128+
minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls
129+
allClassMethods = ("all missing methods", makeMethodDefinitions range sigs)
130+
131+
mkAction :: MethodGroup -> [Command |? CodeAction]
132+
mkAction (name, methods)
124133
= [ mkCodeAction title
125134
$ mkLspCommand plId codeActionCommandId title
126-
(Just $ mkCmdParams methodGroup False)
135+
(Just $ mkCmdParams methods False)
127136
, mkCodeAction titleWithSig
128137
$ mkLspCommand plId codeActionCommandId titleWithSig
129-
(Just $ mkCmdParams methodGroup True)
138+
(Just $ mkCmdParams methods True)
130139
]
131140
where
132-
title = mkTitle $ fst <$> methodGroup
133-
titleWithSig = mkTitleWithSig $ fst <$> methodGroup
134-
135-
mkTitle methodGroup
136-
= "Add placeholders for "
137-
<> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup))
138-
139-
mkTitleWithSig methodGroup = mkTitle methodGroup <> " with signature(s)"
141+
title = "Add placeholders for " <> name
142+
titleWithSig = title <> " with signature(s)"
140143

141144
mkCmdParams methodGroup withSig =
142145
[toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]
@@ -211,15 +214,37 @@ isInstanceValBind :: ContextInfo -> Bool
211214
isInstanceValBind (ValBind InstanceBind _ _) = True
212215
isInstanceValBind _ = False
213216

214-
-- Return (name text, signature text)
215-
minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [[(T.Text, T.Text)]]
216-
minDefToMethodGroups range sigs = go
217+
type MethodSignature = T.Text
218+
type MethodName = T.Text
219+
type MethodDefinition = (MethodName, MethodSignature)
220+
type MethodGroup = (T.Text, [MethodDefinition])
221+
222+
makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition
223+
makeMethodDefinition sig = (name, signature)
224+
where
225+
name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
226+
signature = bindRendered sig
227+
228+
makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
229+
makeMethodDefinitions range sigs =
230+
[ makeMethodDefinition sig
231+
| sig <- sigs
232+
, inRange range (getSrcSpan $ bindName sig)
233+
]
234+
235+
signatureToName :: InstanceBindTypeSig -> T.Text
236+
signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
237+
238+
-- Return [groupName text, [(methodName text, signature text)]]
239+
minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
240+
minDefToMethodGroups range sigs minDef = makeMethodGroup <$> go minDef
217241
where
218-
go (Var mn) = [[ (T.pack . occNameString . occName $ mn, bindRendered sig)
219-
| sig <- sigs
220-
, inRange range (getSrcSpan $ bindName sig)
221-
, printOutputable mn == T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
222-
]]
242+
makeMethodGroup methodDefinitions =
243+
let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions
244+
in (name, methodDefinitions)
245+
246+
go (Var mn) = pure $ makeMethodDefinitions range $ filter ((==) (printOutputable mn) . signatureToName) sigs
223247
go (Or ms) = concatMap (go . unLoc) ms
224248
go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)
225249
go (Parens m) = go (unLoc m)
250+

‎plugins/hls-class-plugin/test/Main.hs‎

Lines changed: 29 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Main
1212
import Control.Lens (Prism', prism', (^.), (^..), (^?))
1313
import Control.Monad (void)
1414
import Data.Maybe
15+
import qualified Data.Text as T
1516
import qualified Ide.Plugin.Class as Class
1617
import qualified Language.LSP.Types.Lens as J
1718
import System.FilePath
@@ -31,23 +32,21 @@ tests = testGroup
3132
codeActionTests :: TestTree
3233
codeActionTests = testGroup
3334
"code actions"
34-
[ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do
35-
runSessionWithServer classPlugin testDataDir $ do
36-
doc <- openDoc "T1.hs" "haskell"
37-
_ <- waitForDiagnosticsFromSource doc "typecheck"
38-
caResults <- getAllCodeActions doc
39-
liftIO $ map (^? _CACodeAction . J.title) caResults
40-
@?=
41-
[ Just "Add placeholders for '=='"
42-
, Just "Add placeholders for '==' with signature(s)"
43-
, Just "Add placeholders for '/='"
44-
, Just "Add placeholders for '/=' with signature(s)"
45-
]
35+
[ expectCodeActionsAvailable "Produces addMinimalMethodPlaceholders code actions for one instance" "T1"
36+
[ "Add placeholders for '=='"
37+
, "Add placeholders for '==' with signature(s)"
38+
, "Add placeholders for '/='"
39+
, "Add placeholders for '/=' with signature(s)"
40+
, "Add placeholders for all missing methods"
41+
, "Add placeholders for all missing methods with signature(s)"
42+
]
4643
, goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
4744
executeCodeAction eqAction
4845
, goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do
4946
executeCodeAction neAction
50-
, goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do
47+
, goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ \(_:_:_:_:allMethodsAction:_) -> do
48+
executeCodeAction allMethodsAction
49+
, goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:_:_:fmapAction:_) -> do
5150
executeCodeAction fmapAction
5251
, goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
5352
executeCodeAction mmAction
@@ -70,6 +69,11 @@ codeActionTests = testGroup
7069
executeCodeAction eqWithSig
7170
, goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do
7271
executeCodeAction multi
72+
, expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" []
73+
, expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired"
74+
[ "Add placeholders for 'f','g'"
75+
, "Add placeholders for 'f','g' with signature(s)"
76+
]
7377
]
7478

7579
codeLensTests :: TestTree
@@ -99,7 +103,6 @@ _CACodeAction = prism' InR $ \case
99103
InR action -> Just action
100104
_ -> Nothing
101105

102-
103106
goldenCodeLens :: TestName -> FilePath -> Int -> TestTree
104107
goldenCodeLens title path idx =
105108
goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do
@@ -115,5 +118,17 @@ goldenWithClass title path desc act =
115118
act actions
116119
void $ skipManyTill anyMessage (getDocumentEdit doc)
117120

121+
expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree
122+
expectCodeActionsAvailable title path actionTitles =
123+
testCase title $ do
124+
runSessionWithServer classPlugin testDataDir $ do
125+
doc <- openDoc (path <.> "hs") "haskell"
126+
_ <- waitForDiagnosticsFromSource doc "typecheck"
127+
caResults <- getAllCodeActions doc
128+
liftIO $ map (^? _CACodeAction . J.title) caResults
129+
@?= expectedActions
130+
where
131+
expectedActions = Just <$> actionTitles
132+
118133
testDataDir :: FilePath
119134
testDataDir = "test" </> "testdata"

‎plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module AllMethodsRequired where
2+
3+
class Test a where
4+
f :: a
5+
g :: a
6+
{-# MINIMAL f,g #-}
7+
8+
instance Test [a] where
9+

‎plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module MinimalDefinitionMeet where
2+
3+
data X = X
4+
5+
instance Eq X where
6+
(==) = _

‎plugins/hls-class-plugin/test/testdata/T1.all.expected.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module T1 where
2+
3+
data X = X
4+
5+
instance Eq X where
6+
(==) = _
7+
(/=) = _

0 commit comments

Comments
 (0)