Skip to content

Commit 43b7b3b

Browse files
vidit-odvidit-od
authored
Cursor aware record expansion (#4813)
* Cursor aware record expansion * Nested Positional Constructor + Tests * Implement Reviews
1 parent 14e94b7 commit 43b7b3b

File tree

6 files changed

+167
-10
lines changed

6 files changed

+167
-10
lines changed

‎plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs‎

Lines changed: 28 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,12 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
1919
import Control.Monad.Trans.Class (lift)
2020
import Control.Monad.Trans.Maybe
2121
import Data.Aeson (ToJSON (toJSON))
22+
import Data.Function (on)
2223
import Data.Generics (GenericQ, everything,
2324
everythingBut, extQ, mkQ)
2425
import qualified Data.IntMap.Strict as IntMap
25-
import Data.List (find, intersperse)
26+
import Data.List (find, intersperse,
27+
sortOn)
2628
import qualified Data.Map as Map
2729
import Data.Maybe (fromMaybe, isJust,
2830
mapMaybe, maybeToList)
@@ -99,6 +101,7 @@ import Ide.Plugin.Error (PluginError (PluginIntern
99101
import Ide.Plugin.RangeMap (RangeMap)
100102
import qualified Ide.Plugin.RangeMap as RangeMap
101103
import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand)
104+
import Ide.PluginUtils (subRange)
102105
import Ide.Types (PluginDescriptor (..),
103106
PluginId (..),
104107
PluginMethodHandler,
@@ -111,7 +114,7 @@ import Language.LSP.Protocol.Message (Method (..),
111114
import Language.LSP.Protocol.Types (CodeAction (..),
112115
CodeActionKind (CodeActionKind_RefactorRewrite),
113116
CodeActionParams (CodeActionParams),
114-
Command, InlayHint (..),
117+
InlayHint (..),
115118
InlayHintLabelPart (InlayHintLabelPart),
116119
InlayHintParams (InlayHintParams, _range, _textDocument),
117120
TextDocumentIdentifier (TextDocumentIdentifier),
@@ -155,17 +158,19 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
155158
CRR {crCodeActions, crCodeActionResolve, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp
156159
-- All we need to build a code action is the list of extensions, and a int to
157160
-- allow us to resolve it later.
158-
let recordUids = [ uid
161+
let recordsWithUid = [ (uid, record)
159162
| uid <- RangeMap.filterByRange range crCodeActions
160163
, Just record <- [IntMap.lookup uid crCodeActionResolve]
161164
-- Only fully saturated constructor applications can be
162165
-- converted to the record syntax through the code action
163166
, isConvertible record
164167
]
165-
let actions = map (mkCodeAction enabledExtensions) recordUids
166-
pure $ InL actions
168+
recordsOnly = map snd recordsWithUid
169+
sortedRecords = sortOn (recordDepth recordsOnly . snd) recordsWithUid
170+
pure $ InL $ case sortedRecords of
171+
(top : _) -> [mkCodeAction enabledExtensions (fst top)]
172+
[] -> []
167173
where
168-
mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
169174
mkCodeAction exts uid = InR CodeAction
170175
{ _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
171176
, _kind = Just CodeActionKind_RefactorRewrite
@@ -266,9 +271,12 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
266271
pure $ InL (concatMap (mkInlayHints nameMap pm) records)
267272
where
268273
mkInlayHints :: UniqFM Name [Name] -> PositionMapping -> RecordInfo -> [InlayHint]
269-
mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr _ _ fla)) =
270-
let textEdits = renderRecordInfoAsTextEdit nameMap record
271-
in mapMaybe (mkInlayHint textEdits pm) fla
274+
mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr sat _ fla)) =
275+
-- Only create inlay hints for fully saturated constructors
276+
case sat of
277+
Saturated -> let textEdits = renderRecordInfoAsTextEdit nameMap record
278+
in mapMaybe (mkInlayHint textEdits pm) fla
279+
Unsaturated -> []
272280
mkInlayHints _ _ _ = []
273281

274282
mkInlayHint :: Maybe TextEdit -> PositionMapping -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint
@@ -296,6 +304,12 @@ mkTitle exts = "Expand record wildcard"
296304
then mempty
297305
else " (needs extension: NamedFieldPuns)"
298306

307+
-- Calculate the nesting depth of a record by counting how many other records
308+
-- contain it. Used to prioritize more deeply nested records in code actions.
309+
recordDepth :: [RecordInfo] -> RecordInfo -> Int
310+
recordDepth allRecords record =
311+
let isSubrangeOf = subRange `on` recordInfoToRange
312+
in length $ filter (`isSubrangeOf` record) allRecords
299313

300314
pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
301315
pragmaEdit exts pragma = if NamedFieldPuns `elem` exts
@@ -602,7 +616,11 @@ getRecCons e@(unLoc -> RecordCon _ _ flds)
602616
getRecCons expr@(unLoc -> app@(HsApp _ _ _)) =
603617
let fieldss = maybeToList $ getFields app []
604618
recInfo = concatMap mkRecInfo fieldss
605-
in (recInfo, not (null recInfo))
619+
-- Search control for positional constructors.
620+
-- True stops further (nested) searching; False allows recursive search.
621+
-- Currently hardcoded to False to enable nested positional searches.
622+
-- Use `in (recInfo, not (null recInfo))` to disable nested searching.
623+
in (recInfo, False)
606624
where
607625
mkRecInfo :: RecordAppExpr -> [RecordInfo]
608626
mkRecInfo appExpr =

‎plugins/hls-explicit-record-fields-plugin/test/Main.hs‎

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,8 @@ test = testGroup "explicit-fields"
3838
, mkTestNoAction "Prefix" "Prefix" 10 11 10 28
3939
, mkTestNoAction "PartiallyAppliedCon" "PartiallyAppliedCon" 7 8 7 12
4040
, mkTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15
41+
, mkTest "CursorAwarePositional" "CursorPositional" 15 26 15 34
42+
, mkTest "CursorAwareRecords" "CursorRecords" 9 40 9 40
4143
]
4244
, testGroup "inlay hints"
4345
[ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do
@@ -292,6 +294,89 @@ test = testGroup "explicit-fields"
292294
, _paddingLeft = Nothing
293295
}
294296
]
297+
, mkInlayHintsTest "CursorRecords" Nothing 9 $ \ih -> do
298+
let mkLabelPart' = mkLabelPartOffsetLength "CursorRecords"
299+
a0 <- mkLabelPart' 3 14 "a0"
300+
a1 <- mkLabelPart' 4 14 "a1"
301+
a11 <- mkLabelPart' 4 25 "a11"
302+
a2 <- mkLabelPart' 5 14 "a2"
303+
a3 <- mkLabelPart' 6 14 "a3"
304+
(@?=) ih
305+
[ defInlayHint
306+
{ _position = Position 9 52
307+
, _label = InR [ a3 ]
308+
, _textEdits = Just [ mkLineTextEdit "L1 {l2 = L2 {l3 = L3 {l4 = L4 {..}, ..}, ..}, a3}" 9 5 53 ]
309+
, _tooltip = Just $ InL "Expand record wildcard"
310+
, _paddingLeft = Just True
311+
, _paddingRight = Nothing
312+
, _data_ = Nothing
313+
}
314+
, defInlayHint
315+
{ _position = Position 9 47
316+
, _label = InR [ a2 ]
317+
, _textEdits = Just [ mkLineTextEdit "L2 {l3 = L3 {l4 = L4 {..}, ..}, a2}" 9 14 48 ]
318+
, _tooltip = Just $ InL "Expand record wildcard"
319+
, _paddingLeft = Just True
320+
, _paddingRight = Nothing
321+
, _data_ = Nothing
322+
}
323+
, defInlayHint
324+
{ _position = Position 9 42
325+
, _label = InR [ a1 , InlayHintLabelPart ", " Nothing Nothing Nothing , a11 ]
326+
, _textEdits = Just [ mkLineTextEdit "L3 {l4 = L4 {..}, a1, a11}" 9 23 43 ]
327+
, _tooltip = Just $ InL "Expand record wildcard"
328+
, _paddingLeft = Just True
329+
, _paddingRight = Nothing
330+
, _data_ = Nothing
331+
}
332+
, defInlayHint
333+
{ _position = Position 9 37
334+
, _label = InR [ a0 ]
335+
, _textEdits = Just [ mkLineTextEdit "L4 {a0}" 9 31 38 ]
336+
, _tooltip = Just $ InL "Expand record wildcard"
337+
, _paddingLeft = Just True
338+
, _paddingRight = Nothing
339+
, _data_ = Nothing
340+
}
341+
]
342+
, mkInlayHintsTest "CursorPositional" Nothing 15 $ \ih -> do
343+
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "CursorPositional"
344+
middle <- mkLabelPart' 2 2 "middle="
345+
inner <- mkLabelPart' 6 2 "inner="
346+
foo <- mkLabelPart' 10 2 "foo="
347+
bar <- mkLabelPart' 11 4 "bar="
348+
(@?=) ih
349+
[ defInlayHint
350+
{ _position = Position 15 14
351+
, _label = InR [ middle ]
352+
, _textEdits = Just [ mkLineTextEdit "RecOuter { middle = (RecMiddle (RecInner 'c' 42)) }" 15 5 43 ]
353+
, _tooltip = Just $ InL "Expand positional record"
354+
, _paddingLeft = Nothing
355+
}
356+
, defInlayHint
357+
{ _position = Position 15 25
358+
, _label = InR [ inner ]
359+
, _textEdits = Just [ mkLineTextEdit "RecMiddle { inner = (RecInner 'c' 42) }" 15 15 42 ]
360+
, _tooltip = Just $ InL "Expand positional record"
361+
, _paddingLeft = Nothing
362+
}
363+
, defInlayHint
364+
{ _position = Position 15 35
365+
, _label = InR [ foo ]
366+
, _textEdits =
367+
Just [ mkLineTextEdit "RecInner { foo = 'c', bar = 42 }" 15 26 41 ]
368+
, _tooltip = Just $ InL "Expand positional record"
369+
, _paddingLeft = Nothing
370+
}
371+
, defInlayHint
372+
{ _position = Position 15 39
373+
, _label = InR [ bar ]
374+
, _textEdits =
375+
Just [ mkLineTextEdit "RecInner { foo = 'c', bar = 42 }" 15 26 41 ]
376+
, _tooltip = Just $ InL "Expand positional record"
377+
, _paddingLeft = Nothing
378+
}
379+
]
295380
]
296381
]
297382

‎plugins/hls-explicit-record-fields-plugin/test/testdata/CursorPositional.expected.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module CursorPositional where
2+
data RecOuter = RecOuter{
3+
middle :: RecMiddle
4+
}
5+
6+
data RecMiddle = RecMiddle {
7+
inner :: RecInner
8+
}
9+
10+
data RecInner = RecInner{
11+
foo :: Char
12+
, bar :: Int
13+
}
14+
15+
ex :: RecOuter
16+
ex = RecOuter (RecMiddle (RecInner { foo = 'c', bar = 42 }))

‎plugins/hls-explicit-record-fields-plugin/test/testdata/CursorPositional.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module CursorPositional where
2+
data RecOuter = RecOuter{
3+
middle :: RecMiddle
4+
}
5+
6+
data RecMiddle = RecMiddle {
7+
inner :: RecInner
8+
}
9+
10+
data RecInner = RecInner{
11+
foo :: Char
12+
, bar :: Int
13+
}
14+
15+
ex :: RecOuter
16+
ex = RecOuter (RecMiddle (RecInner 'c' 42))

‎plugins/hls-explicit-record-fields-plugin/test/testdata/CursorRecords.expected.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
module CursorRecords where
3+
4+
data L4 = L4{ a0 :: Int}
5+
data L3 = L3{ a1 :: Int, a11 :: Int, l4 :: L4}
6+
data L2 = L2{ a2 :: Int, l3 :: L3}
7+
data L1 = L1{ a3 :: Int, l2 :: L2}
8+
9+
test :: L1 -> Int
10+
test L1 {l2 = L2{ l3 = L3 {l4 = L4 {..}, a1, a11}, ..}, ..} =
11+
a0 + a1 + a2 + a3 + a11

‎plugins/hls-explicit-record-fields-plugin/test/testdata/CursorRecords.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
module CursorRecords where
3+
4+
data L4 = L4{ a0 :: Int}
5+
data L3 = L3{ a1 :: Int, a11 :: Int, l4 :: L4}
6+
data L2 = L2{ a2 :: Int, l3 :: L3}
7+
data L1 = L1{ a3 :: Int, l2 :: L2}
8+
9+
test :: L1 -> Int
10+
test L1 {l2 = L2{ l3 = L3{l4 = L4 {..}, ..}, ..}, ..} =
11+
a0 + a1 + a2 + a3 + a11

0 commit comments

Comments
 (0)