Skip to content

Commit 1810a67

Browse files
jetjinserjetjinser
committed
filter label with name
1 parent 0dd9ef3 commit 1810a67

File tree

2 files changed

+72
-62
lines changed

2 files changed

+72
-62
lines changed

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

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -226,6 +226,12 @@ instance NFData (HsExpr (GhcPass Renamed)) where
226226
instance NFData (Pat (GhcPass Renamed)) where
227227
rnf = rwhnf
228228

229+
instance NFData (HsExpr (GhcPass Typechecked)) where
230+
rnf = rwhnf
231+
232+
instance NFData (Pat (GhcPass Typechecked)) where
233+
rnf = rwhnf
234+
229235
instance NFData Extension where
230236
rnf = rwhnf
231237

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

Lines changed: 66 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -26,14 +26,16 @@ import Data.Unique (hashUnique, newUnique)
2626

2727
import Control.Monad (replicateM)
2828
import Data.Aeson (ToJSON (toJSON))
29-
import Data.List (intersperse)
29+
import Data.List (find, intersperse)
30+
import qualified Data.Text as T
3031
import Development.IDE (IdeState,
3132
Location (Location),
3233
Pretty (..),
33-
Range (_end),
34+
Range (Range, _end, _start),
3435
Recorder (..), Rules,
3536
WithPriority (..),
3637
defineNoDiagnostics,
38+
getDefinition, printName,
3739
realSrcSpanToRange,
3840
shakeExtras,
3941
srcSpanToRange, viaShow)
@@ -42,20 +44,27 @@ import Development.IDE.Core.PositionMapping (toCurrentRange)
4244
import Development.IDE.Core.RuleTypes (TcModuleResult (..),
4345
TypeCheck (..))
4446
import qualified Development.IDE.Core.Shake as Shake
45-
import Development.IDE.GHC.Compat (HsConDetails (RecCon),
46-
HsExpr (XExpr),
47-
HsRecFields (..), LPat,
48-
Outputable, getLoc,
47+
import Development.IDE.GHC.Compat (FieldOcc (FieldOcc),
48+
GhcPass, GhcTc,
49+
HasSrcSpan (getLoc),
50+
HsConDetails (RecCon),
51+
HsExpr (HsVar, XExpr),
52+
HsFieldBind (hfbLHS),
53+
HsRecFields (..),
54+
Identifier, LPat,
55+
NamedThing (getName),
56+
Outputable,
57+
TcGblEnv (tcg_binds),
58+
Var (varName),
59+
XXExprGhcTc (..),
4960
recDotDot, unLoc)
5061
import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns),
51-
GhcPass,
5262
HsExpr (RecordCon, rcon_flds),
5363
HsRecField, LHsExpr,
54-
LocatedA, Name,
55-
Pass (..), Pat (..),
64+
LocatedA, Name, Pat (..),
5665
RealSrcSpan, UniqFM,
5766
conPatDetails, emptyUFM,
58-
hfbPun, hfbRHS, hs_valds,
67+
hfbPun, hfbRHS,
5968
lookupUFM,
6069
mapConPatDetail, mapLoc,
6170
pattern RealSrcSpan,
@@ -95,14 +104,11 @@ import Language.LSP.Protocol.Types (CodeAction (..),
95104
TextDocumentIdentifier (TextDocumentIdentifier),
96105
TextEdit (TextEdit),
97106
WorkspaceEdit (WorkspaceEdit),
98-
isSubrangeOf,
99107
type (|?) (InL, InR))
100108

101109

102110
#if __GLASGOW_HASKELL__ < 910
103111
import Development.IDE.GHC.Compat (HsExpansion (HsExpanded))
104-
#else
105-
import Development.IDE.GHC.Compat (XXExprGhcRn (..))
106112
#endif
107113

108114
data Log
@@ -174,44 +180,45 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent
174180
pragma <- getFirstPragma pId state nfp
175181
runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
176182
(crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp
177-
let records = [ record
183+
let -- Get all records with dotdot in current nfp
184+
records = [ record
178185
| Just range <- [toCurrentRange pm visibleRange]
179-
, uid <- filterByRange' range crCodeActions
180-
, Just record <- [IntMap.lookup uid crCodeActionResolve]
181-
]
182-
-- TODO: definition location?
183-
-- locations = [ getDefinition nfp pos
184-
-- | record <- records
185-
-- , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record
186-
-- ]
187-
-- defnLocsList <- liftIO $ runIdeAction "" (shakeExtras state) (sequence locations)
188-
pure $ InL $ mapMaybe (mkInlayHints crr pragma) records
186+
, uid <- RangeMap.flippedFilterByRange range crCodeActions
187+
, Just record <- [IntMap.lookup uid crCodeActionResolve] ]
188+
-- Get the definition of each dotdot of record
189+
locations = [ getDefinition nfp pos
190+
| record <- records
191+
, pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ]
192+
defnLocsList <- liftIO $ Shake.runIdeAction "ExplicitFields.getDefinition" (shakeExtras state) (sequence locations)
193+
pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records)
189194
where
190-
mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> RecordInfo -> Maybe InlayHint
191-
mkInlayHints CRR {enabledExtensions, nameMap} pragma record =
195+
mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
196+
mkInlayHints CRR {enabledExtensions, nameMap} pragma (defnLocs, record) =
192197
let range = recordInfoToDotDotRange record
193198
textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record)
194199
<> maybeToList (pragmaEdit enabledExtensions pragma)
195-
values = renderRecordInfoAsLabelValue record
200+
names = renderRecordInfoAsLabelName record
196201
in do
197-
range' <- range
198-
values' <- values
199-
let -- valueWithLoc = zip values' (sequence defnLocs)
200-
loc = Location uri range'
201-
label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart (map (, Just loc) values')
202-
pure $ InlayHint { _position = _end range'
202+
end <- fmap _end range
203+
names' <- names
204+
defnLocs' <- defnLocs
205+
let excludeDotDot (Location _ (Range _ pos)) = pos /= end
206+
-- find location from dotdot definitions that name equal to label name
207+
findLocation t = fmap fst . find (either (const False) ((==) t) . snd) . filter (excludeDotDot . fst)
208+
valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
209+
-- use `, ` to separate labels with definition location
210+
label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc
211+
pure $ InlayHint { _position = end -- at the end of dotdot
203212
, _label = InR label
204213
, _kind = Nothing -- neither a type nor a parameter
205-
, _textEdits = Just textEdits
206-
, _tooltip = Just $ InL (mkTitle enabledExtensions)
214+
, _textEdits = Just textEdits -- same as CodeAction
215+
, _tooltip = Just $ InL (mkTitle enabledExtensions) -- same as CodeAction
207216
, _paddingLeft = Just True -- padding after dotdot
208217
, _paddingRight = Nothing
209218
, _data_ = Nothing
210219
}
211-
filterByRange' range = map snd . filter (flip isSubrangeOf range . fst) . RangeMap.unRangeMap
212220
mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing
213221

214-
215222
mkTitle :: [Extension] -> Text
216223
mkTitle exts = "Expand record wildcard"
217224
<> if NamedFieldPuns `elem` exts
@@ -249,11 +256,7 @@ collectRecordsRule recorder =
249256
toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid)
250257

251258
getRecords :: TcModuleResult -> [RecordInfo]
252-
#if __GLASGOW_HASKELL__ < 910
253-
getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds
254-
#else
255-
getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds
256-
#endif
259+
getRecords (tcg_binds . tmrTypechecked -> valBinds) = collectRecords valBinds
257260

258261
collectNamesRule :: Rules ()
259262
collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do
@@ -318,8 +321,8 @@ instance Show CollectNamesResult where
318321
type instance RuleResult CollectNames = CollectNamesResult
319322

320323
data RecordInfo
321-
= RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed))
322-
| RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed))
324+
= RecordInfoPat RealSrcSpan (Pat GhcTc)
325+
| RecordInfoCon RealSrcSpan (HsExpr GhcTc)
323326
deriving (Generic)
324327

325328
instance Pretty RecordInfo where
@@ -339,9 +342,9 @@ renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit
339342
renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat
340343
renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr
341344

342-
renderRecordInfoAsLabelValue :: RecordInfo -> Maybe [Text]
343-
renderRecordInfoAsLabelValue (RecordInfoPat _ pat) = showRecordPatFlds pat
344-
renderRecordInfoAsLabelValue (RecordInfoCon _ expr) = showRecordConFlds expr
345+
renderRecordInfoAsLabelName :: RecordInfo -> Maybe [Name]
346+
renderRecordInfoAsLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat
347+
renderRecordInfoAsLabelName (RecordInfoCon _ expr) = showRecordConFlds expr
345348

346349

347350
-- | Checks if a 'Name' is referenced in the given map of names. The
@@ -362,11 +365,11 @@ filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names)
362365

363366

364367
preprocessRecordPat
365-
:: p ~ GhcPass 'Renamed
368+
:: p ~ GhcTc
366369
=> UniqFM Name [Name]
367370
-> HsRecFields p (LPat p)
368371
-> HsRecFields p (LPat p)
369-
preprocessRecordPat = preprocessRecord (getFieldName . unLoc)
372+
preprocessRecordPat = preprocessRecord (fmap varName . getFieldName . unLoc)
370373
where getFieldName x = case unLoc (hfbRHS x) of
371374
VarPat _ x' -> Just $ unLoc x'
372375
_ -> Nothing
@@ -427,13 +430,13 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' }
427430
puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns
428431

429432

430-
showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text
433+
showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text
431434
showRecordPat names = fmap printOutputable . mapConPatDetail (\case
432435
RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)
433436
_ -> Nothing)
434437

435-
showRecordPatFlds :: Pat (GhcPass 'Renamed) -> Maybe [Text]
436-
showRecordPatFlds (ConPat _ _ args) = fmap (fmap printOutputable . rec_flds) (m args)
438+
showRecordPatFlds :: Pat GhcTc -> Maybe [Name]
439+
showRecordPatFlds (ConPat _ _ args) = fmap (fmap ((\case FieldOcc x _ -> getName x) . unLoc . hfbLHS . unLoc) . rec_flds) (m args)
437440
where
438441
m (RecCon flds) = Just $ processRecordFlds flds
439442
m _ = Nothing
@@ -445,8 +448,11 @@ showRecordCon expr@(RecordCon _ _ flds) =
445448
expr { rcon_flds = preprocessRecordCon flds }
446449
showRecordCon _ = Nothing
447450

448-
showRecordConFlds :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe [Text]
449-
showRecordConFlds (RecordCon _ _ flds) = Just $ fmap printOutputable (rec_flds $ processRecordFlds flds)
451+
showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name]
452+
showRecordConFlds (RecordCon _ _ flds) = mapM (m . unLoc . hfbRHS . unLoc) (rec_flds $ processRecordFlds flds)
453+
where
454+
m (HsVar _ lidp) = Just $ getName lidp
455+
m _ = Nothing
450456
showRecordConFlds _ = Nothing
451457

452458

@@ -466,7 +472,7 @@ collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` get
466472
collectNames :: GenericQ (UniqFM Name [Name])
467473
collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x]))
468474

469-
getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)
475+
getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool)
470476
-- When we stumble upon an occurrence of HsExpanded, we only want to follow a
471477
-- single branch. We do this here, by explicitly returning occurrences from
472478
-- traversing the original branch, and returning True, which keeps syb from
@@ -475,25 +481,23 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)
475481
-- branch
476482

477483
#if __GLASGOW_HASKELL__ >= 910
478-
getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True)
484+
getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, True)
479485
#else
480-
getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True)
486+
getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True)
481487
#endif
482488
getRecCons e@(unLoc -> RecordCon _ _ flds)
483489
| isJust (rec_dotdot flds) = (mkRecInfo e, False)
484490
where
485-
mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo]
491+
mkRecInfo :: LHsExpr GhcTc -> [RecordInfo]
486492
mkRecInfo expr =
487493
[ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]]
488494
getRecCons _ = ([], False)
489495

490-
getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)
496+
getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool)
491497
getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))
492498
| isJust (rec_dotdot flds) = (mkRecInfo conPat, False)
493499
where
494-
mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo]
500+
mkRecInfo :: LPat GhcTc -> [RecordInfo]
495501
mkRecInfo pat =
496502
[ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]
497503
getRecPatterns _ = ([], False)
498-
499-

0 commit comments

Comments
 (0)