Skip to content

Commit f09500b

Browse files
jetjinserfendormichaelpj
authored
Support record positional construction inlay hints (#4447)
* refactor * Support record positional construction inlay hints * restore the missing conditional getRecCons that deleted by mistake * NFData FieldLabel when GHC < 906 * chore: remove wrong comment * refactor: simplify `getFields` case --------- Co-authored-by: fendor <[email protected]> Co-authored-by: Michael Peyton Jones <[email protected]>
1 parent d91b665 commit f09500b

File tree

5 files changed

+233
-53
lines changed

5 files changed

+233
-53
lines changed

‎ghcide/src/Development/IDE/GHC/Orphans.hs

+19-3
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,9 @@
77
-- | Orphan instances for GHC.
88
-- Note that the 'NFData' instances may not be law abiding.
99
module Development.IDE.GHC.Orphans() where
10-
import Development.IDE.GHC.Compat
10+
import Development.IDE.GHC.Compat hiding
11+
(DuplicateRecordFields,
12+
FieldSelectors)
1113
import Development.IDE.GHC.Util
1214

1315
import Control.DeepSeq
@@ -23,9 +25,10 @@ import GHC.Data.Bag
2325
import GHC.Data.FastString
2426
import qualified GHC.Data.StringBuffer as SB
2527
import GHC.Parser.Annotation
26-
import GHC.Types.SrcLoc
27-
28+
import GHC.Types.FieldLabel (DuplicateRecordFields (DuplicateRecordFields, NoDuplicateRecordFields),
29+
FieldSelectors (FieldSelectors, NoFieldSelectors))
2830
import GHC.Types.PkgQual
31+
import GHC.Types.SrcLoc
2932

3033
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
3134

@@ -237,3 +240,16 @@ instance NFData Extension where
237240

238241
instance NFData (UniqFM Name [Name]) where
239242
rnf (ufmToIntMap -> m) = rnf m
243+
244+
#if !MIN_VERSION_ghc(9,5,0)
245+
instance NFData DuplicateRecordFields where
246+
rnf DuplicateRecordFields = ()
247+
rnf NoDuplicateRecordFields = ()
248+
249+
instance NFData FieldSelectors where
250+
rnf FieldSelectors = ()
251+
rnf NoFieldSelectors = ()
252+
253+
instance NFData FieldLabel where
254+
rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
255+
#endif

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

+106-26
Original file line numberDiff line numberDiff line change
@@ -12,52 +12,60 @@ module Ide.Plugin.ExplicitFields
1212
, Log
1313
) where
1414

15+
import Control.Arrow ((&&&))
1516
import Control.Lens ((&), (?~), (^.))
17+
import Control.Monad (replicateM)
1618
import Control.Monad.IO.Class (MonadIO (liftIO))
19+
import Control.Monad.Trans.Class (lift)
1720
import Control.Monad.Trans.Maybe
21+
import Data.Aeson (ToJSON (toJSON))
1822
import Data.Generics (GenericQ, everything,
1923
everythingBut, extQ, mkQ)
2024
import qualified Data.IntMap.Strict as IntMap
25+
import Data.List (find, intersperse)
2126
import qualified Data.Map as Map
2227
import Data.Maybe (fromMaybe, isJust,
2328
mapMaybe, maybeToList)
2429
import Data.Text (Text)
25-
import Data.Unique (hashUnique, newUnique)
26-
27-
import Control.Monad (replicateM)
28-
import Control.Monad.Trans.Class (lift)
29-
import Data.Aeson (ToJSON (toJSON))
30-
import Data.List (find, intersperse)
3130
import qualified Data.Text as T
31+
import Data.Unique (hashUnique, newUnique)
3232
import Development.IDE (IdeState,
3333
Location (Location),
3434
Pretty (..),
3535
Range (Range, _end, _start),
3636
Recorder (..), Rules,
3737
WithPriority (..),
3838
defineNoDiagnostics,
39-
getDefinition, printName,
39+
getDefinition, hsep,
40+
printName,
4041
realSrcSpanToRange,
4142
shakeExtras,
43+
srcSpanToLocation,
4244
srcSpanToRange, viaShow)
4345
import Development.IDE.Core.PluginUtils
4446
import Development.IDE.Core.PositionMapping (toCurrentRange)
4547
import Development.IDE.Core.RuleTypes (TcModuleResult (..),
4648
TypeCheck (..))
4749
import qualified Development.IDE.Core.Shake as Shake
48-
import Development.IDE.GHC.Compat (FieldOcc (FieldOcc),
49-
GhcPass, GhcTc,
50+
import Development.IDE.GHC.Compat (FieldLabel (flSelector),
51+
FieldOcc (FieldOcc),
52+
GenLocated (L), GhcPass,
53+
GhcTc,
5054
HasSrcSpan (getLoc),
5155
HsConDetails (RecCon),
52-
HsExpr (HsVar, XExpr),
56+
HsExpr (HsApp, HsVar, XExpr),
5357
HsFieldBind (hfbLHS),
5458
HsRecFields (..),
5559
Identifier, LPat,
60+
Located,
5661
NamedThing (getName),
5762
Outputable,
5863
TcGblEnv (tcg_binds),
5964
Var (varName),
6065
XXExprGhcTc (..),
66+
conLikeFieldLabels,
67+
nameSrcSpan,
68+
pprNameUnqualified,
6169
recDotDot, unLoc)
6270
import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns),
6371
HsExpr (RecordCon, rcon_flds),
@@ -129,9 +137,10 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta
129137
descriptor recorder plId =
130138
let resolveRecorder = cmapWithPrio LogResolve recorder
131139
(carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider
132-
ihHandlers = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder)
140+
ihDotdotHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintDotdotProvider recorder)
141+
ihPosRecHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintPosRecProvider recorder)
133142
in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit")
134-
{ pluginHandlers = caHandlers <> ihHandlers
143+
{ pluginHandlers = caHandlers <> ihDotdotHandler <> ihPosRecHandler
135144
, pluginCommands = carCommands
136145
, pluginRules = collectRecordsRule recorder *> collectNamesRule
137146
}
@@ -145,9 +154,9 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
145154
let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions)
146155
pure $ InL actions
147156
where
148-
mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
157+
mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
149158
mkCodeAction exts uid = InR CodeAction
150-
{ _title = mkTitle exts
159+
{ _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
151160
, _kind = Just CodeActionKind_RefactorRewrite
152161
, _diagnostics = Nothing
153162
, _isPreferred = Nothing
@@ -167,15 +176,19 @@ codeActionResolveProvider ideState pId ca uri uid = do
167176
record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve
168177
-- We should never fail to render
169178
rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record
170-
let edits = [rendered]
171-
<> maybeToList (pragmaEdit enabledExtensions pragma)
179+
let shouldInsertNamedFieldPuns (RecordInfoApp _ _) = False
180+
shouldInsertNamedFieldPuns _ = True
181+
whenMaybe True x = x
182+
whenMaybe False _ = Nothing
183+
edits = [rendered]
184+
<> maybeToList (whenMaybe (shouldInsertNamedFieldPuns record) (pragmaEdit enabledExtensions pragma))
172185
pure $ ca & L.edit ?~ mkWorkspaceEdit edits
173186
where
174187
mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit
175188
mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing
176189

177-
inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
178-
inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
190+
inlayHintDotdotProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
191+
inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
179192
nfp <- getNormalizedFilePathE uri
180193
pragma <- getFirstPragma pId state nfp
181194
runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
@@ -186,18 +199,18 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent
186199
, uid <- RangeMap.elementsInRange range crCodeActions
187200
, Just record <- [IntMap.lookup uid crCodeActionResolve] ]
188201
-- Get the definition of each dotdot of record
189-
locations = [ getDefinition nfp pos
202+
locations = [ fmap (,record) (getDefinition nfp pos)
190203
| record <- records
191204
, pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ]
192205
defnLocsList <- lift $ sequence locations
193-
pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records)
206+
pure $ InL $ mapMaybe (mkInlayHint crr pragma) defnLocsList
194207
where
195-
mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
196-
mkInlayHints CRR {enabledExtensions, nameMap} pragma (defnLocs, record) =
208+
mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
209+
mkInlayHint CRR {enabledExtensions, nameMap} pragma (defnLocs, record) =
197210
let range = recordInfoToDotDotRange record
198211
textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record)
199212
<> maybeToList (pragmaEdit enabledExtensions pragma)
200-
names = renderRecordInfoAsLabelName record
213+
names = renderRecordInfoAsDotdotLabelName record
201214
in do
202215
end <- fmap _end range
203216
names' <- names
@@ -224,6 +237,40 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent
224237
}
225238
mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing
226239

240+
241+
inlayHintPosRecProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
242+
inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
243+
nfp <- getNormalizedFilePathE uri
244+
runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
245+
(CRR {crCodeActions, nameMap, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp
246+
let records = [ record
247+
| Just range <- [toCurrentRange pm visibleRange]
248+
, uid <- RangeMap.elementsInRange range crCodeActions
249+
, Just record <- [IntMap.lookup uid crCodeActionResolve] ]
250+
pure $ InL (concatMap (mkInlayHints nameMap) records)
251+
where
252+
mkInlayHints :: UniqFM Name [Name] -> RecordInfo -> [InlayHint]
253+
mkInlayHints nameMap record@(RecordInfoApp _ (RecordAppExpr _ fla)) =
254+
let textEdits = renderRecordInfoAsTextEdit nameMap record
255+
in mapMaybe (mkInlayHint textEdits) fla
256+
mkInlayHints _ _ = []
257+
mkInlayHint :: Maybe TextEdit -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint
258+
mkInlayHint te (label, _) =
259+
let (name, loc) = ((flSelector . unLoc) &&& (srcSpanToLocation . getLoc)) label
260+
fieldDefLoc = srcSpanToLocation (nameSrcSpan name)
261+
in do
262+
(Location _ recRange) <- loc
263+
pure InlayHint { _position = _start recRange
264+
, _label = InR $ pure (mkInlayHintLabelPart name fieldDefLoc)
265+
, _kind = Nothing -- neither a type nor a parameter
266+
, _textEdits = Just (maybeToList te) -- same as CodeAction
267+
, _tooltip = Just $ InL "Expand positional record" -- same as CodeAction
268+
, _paddingLeft = Nothing
269+
, _paddingRight = Nothing
270+
, _data_ = Nothing
271+
}
272+
mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing
273+
227274
mkTitle :: [Extension] -> Text
228275
mkTitle exts = "Expand record wildcard"
229276
<> if NamedFieldPuns `elem` exts
@@ -303,6 +350,7 @@ data CollectRecordsResult = CRR
303350

304351
instance NFData CollectRecordsResult
305352
instance NFData RecordInfo
353+
instance NFData RecordAppExpr
306354

307355
instance Show CollectRecordsResult where
308356
show _ = "<CollectRecordsResult>"
@@ -325,18 +373,25 @@ instance Show CollectNamesResult where
325373

326374
type instance RuleResult CollectNames = CollectNamesResult
327375

376+
data RecordAppExpr = RecordAppExpr (LHsExpr GhcTc) [(Located FieldLabel, HsExpr GhcTc)]
377+
deriving (Generic)
378+
328379
data RecordInfo
329380
= RecordInfoPat RealSrcSpan (Pat GhcTc)
330381
| RecordInfoCon RealSrcSpan (HsExpr GhcTc)
382+
| RecordInfoApp RealSrcSpan RecordAppExpr
331383
deriving (Generic)
332384

333385
instance Pretty RecordInfo where
334386
pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p)
335387
pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)
388+
pretty (RecordInfoApp ss (RecordAppExpr _ fla))
389+
= pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
336390

337391
recordInfoToRange :: RecordInfo -> Range
338392
recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
339393
recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss
394+
recordInfoToRange (RecordInfoApp ss _) = realSrcSpanToRange ss
340395

341396
recordInfoToDotDotRange :: RecordInfo -> Maybe Range
342397
recordInfoToDotDotRange (RecordInfoPat _ (ConPat _ _ (RecCon flds))) = srcSpanToRange . getLoc =<< rec_dotdot flds
@@ -346,10 +401,12 @@ recordInfoToDotDotRange _ = Nothing
346401
renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit
347402
renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat
348403
renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr
404+
renderRecordInfoAsTextEdit _ (RecordInfoApp ss appExpr) = TextEdit (realSrcSpanToRange ss) <$> showRecordApp appExpr
349405

350-
renderRecordInfoAsLabelName :: RecordInfo -> Maybe [Name]
351-
renderRecordInfoAsLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat
352-
renderRecordInfoAsLabelName (RecordInfoCon _ expr) = showRecordConFlds expr
406+
renderRecordInfoAsDotdotLabelName :: RecordInfo -> Maybe [Name]
407+
renderRecordInfoAsDotdotLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat
408+
renderRecordInfoAsDotdotLabelName (RecordInfoCon _ expr) = showRecordConFlds expr
409+
renderRecordInfoAsDotdotLabelName _ = Nothing
353410

354411

355412
-- | Checks if a 'Name' is referenced in the given map of names. The
@@ -468,6 +525,12 @@ showRecordConFlds (RecordCon _ _ flds) =
468525
getFieldName = getVarName . unLoc . hfbRHS . unLoc
469526
showRecordConFlds _ = Nothing
470527

528+
showRecordApp :: RecordAppExpr -> Maybe Text
529+
showRecordApp (RecordAppExpr recConstr fla)
530+
= Just $ printOutputable recConstr <> " { "
531+
<> T.intercalate ", " (showFieldWithArg <$> fla)
532+
<> " }"
533+
where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg
471534

472535
collectRecords :: GenericQ [RecordInfo]
473536
collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
@@ -504,6 +567,23 @@ getRecCons e@(unLoc -> RecordCon _ _ flds)
504567
mkRecInfo :: LHsExpr GhcTc -> [RecordInfo]
505568
mkRecInfo expr =
506569
[ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]]
570+
getRecCons expr@(unLoc -> app@(HsApp _ _ _)) =
571+
let fieldss = maybeToList $ getFields app []
572+
recInfo = concatMap mkRecInfo fieldss
573+
in (recInfo, not (null recInfo))
574+
where
575+
mkRecInfo :: RecordAppExpr -> [RecordInfo]
576+
mkRecInfo appExpr =
577+
[ RecordInfoApp realSpan' appExpr | RealSrcSpan realSpan' _ <- [ getLoc expr ] ]
578+
579+
getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr
580+
getFields (HsApp _ constr@(unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) arg) args
581+
| not (null fls)
582+
= Just (RecordAppExpr constr labelWithArgs)
583+
where labelWithArgs = zipWith mkLabelWithArg fls (arg : args)
584+
mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg)
585+
getFields (HsApp _ constr arg) args = getFields (unLoc constr) (arg : args)
586+
getFields _ _ = Nothing
507587
getRecCons _ = ([], False)
508588

509589
getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool)

0 commit comments

Comments
 (0)