Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Support record positional construction inlay hints #4447

Merged
merged 9 commits into from
Dec 24, 2024
Merged

Support record positional construction inlay hints #4447

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
5898472
refactor
jetjinser Nov 8, 2024
9478b2c
Support record positional construction inlay hints
jetjinser Nov 8, 2024
67187b5
restore the missing conditional getRecCons
jetjinser Nov 11, 2024
b7f110f
NFData FieldLabel when GHC < 906
jetjinser Nov 11, 2024
84cc4fa
Merge branch 'master' into inlay-hints-positional-record
fendor Dec 1, 2024
d96cf67
chore: remove wrong comment
jetjinser Dec 1, 2024
07caefe
refactor: simplify `getFields` case
jetjinser Dec 1, 2024
e1d401f
Merge remote-tracking branch 'upstream/master' into inlay-hints-posit…
jetjinser Dec 2, 2024
3609ee7
Merge branch 'master' into inlay-hints-positional-record
michaelpj Dec 24, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
22 changes: 19 additions & 3 deletions ghcide/src/Development/IDE/GHC/Orphans.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,9 @@
-- | Orphan instances for GHC.
-- Note that the 'NFData' instances may not be law abiding.
module Development.IDE.GHC.Orphans() where
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Compat hiding
(DuplicateRecordFields,
FieldSelectors)
import Development.IDE.GHC.Util

import Control.DeepSeq
Expand All @@ -23,9 +25,10 @@ import GHC.Data.Bag
import GHC.Data.FastString
import qualified GHC.Data.StringBuffer as SB
import GHC.Parser.Annotation
import GHC.Types.SrcLoc

import GHC.Types.FieldLabel (DuplicateRecordFields (DuplicateRecordFields, NoDuplicateRecordFields),
FieldSelectors (FieldSelectors, NoFieldSelectors))
import GHC.Types.PkgQual
import GHC.Types.SrcLoc

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

Expand Down Expand Up @@ -237,3 +240,16 @@ instance NFData Extension where

instance NFData (UniqFM Name [Name]) where
rnf (ufmToIntMap -> m) = rnf m

#if !MIN_VERSION_ghc(9,5,0)
instance NFData DuplicateRecordFields where
rnf DuplicateRecordFields = ()
rnf NoDuplicateRecordFields = ()

instance NFData FieldSelectors where
rnf FieldSelectors = ()
rnf NoFieldSelectors = ()

instance NFData FieldLabel where
rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
#endif
132 changes: 106 additions & 26 deletions plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,52 +12,60 @@ module Ide.Plugin.ExplicitFields
, Log
) where

import Control.Arrow ((&&&))
import Control.Lens ((&), (?~), (^.))
import Control.Monad (replicateM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Data.Aeson (ToJSON (toJSON))
import Data.Generics (GenericQ, everything,
everythingBut, extQ, mkQ)
import qualified Data.IntMap.Strict as IntMap
import Data.List (find, intersperse)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust,
mapMaybe, maybeToList)
import Data.Text (Text)
import Data.Unique (hashUnique, newUnique)

import Control.Monad (replicateM)
import Control.Monad.Trans.Class (lift)
import Data.Aeson (ToJSON (toJSON))
import Data.List (find, intersperse)
import qualified Data.Text as T
import Data.Unique (hashUnique, newUnique)
import Development.IDE (IdeState,
Location (Location),
Pretty (..),
Range (Range, _end, _start),
Recorder (..), Rules,
WithPriority (..),
defineNoDiagnostics,
getDefinition, printName,
getDefinition, hsep,
printName,
realSrcSpanToRange,
shakeExtras,
srcSpanToLocation,
srcSpanToRange, viaShow)
import Development.IDE.Core.PluginUtils
import Development.IDE.Core.PositionMapping (toCurrentRange)
import Development.IDE.Core.RuleTypes (TcModuleResult (..),
TypeCheck (..))
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat (FieldOcc (FieldOcc),
GhcPass, GhcTc,
import Development.IDE.GHC.Compat (FieldLabel (flSelector),
FieldOcc (FieldOcc),
GenLocated (L), GhcPass,
GhcTc,
HasSrcSpan (getLoc),
HsConDetails (RecCon),
HsExpr (HsVar, XExpr),
HsExpr (HsApp, HsVar, XExpr),
HsFieldBind (hfbLHS),
HsRecFields (..),
Identifier, LPat,
Located,
NamedThing (getName),
Outputable,
TcGblEnv (tcg_binds),
Var (varName),
XXExprGhcTc (..),
conLikeFieldLabels,
nameSrcSpan,
pprNameUnqualified,
recDotDot, unLoc)
import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns),
HsExpr (RecordCon, rcon_flds),
Expand Down Expand Up @@ -129,9 +137,10 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta
descriptor recorder plId =
let resolveRecorder = cmapWithPrio LogResolve recorder
(carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider
ihHandlers = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder)
ihDotdotHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintDotdotProvider recorder)
ihPosRecHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintPosRecProvider recorder)
in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit")
{ pluginHandlers = caHandlers <> ihHandlers
{ pluginHandlers = caHandlers <> ihDotdotHandler <> ihPosRecHandler
, pluginCommands = carCommands
, pluginRules = collectRecordsRule recorder *> collectNamesRule
}
Expand All @@ -145,9 +154,9 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions)
pure $ InL actions
where
mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
mkCodeAction exts uid = InR CodeAction
{ _title = mkTitle exts
{ _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The existing codeActionProvider only needs "the list of extensions, and a int to allow us to resolve it later", but here mkTitle needs to be decided based on the RecordInfo how to generate it; If the RecordInfo is obtained here, does it not conform to the idea of ​​resolve?

should I adjust the RecordInfo to make two codeActionProvider? Or is there any better way?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think we probably don't want to get the RecordInfo here if we can avoid it, that's the expensive bit, right?

I would have thought that the code action doesn't apply it all if it's a RecordInfoApp. Isn't the code action only for record wildcards?

Copy link
Contributor Author

@jetjinser jetjinser Dec 1, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, I also think we should avoid getting RecordInfo before resolve.

Since RecordInfoApp is a constructor of RecordInfo, so it is also processed in the code action provider that process RecordInfo.
I thought that the construction of positional record can also have code actions, which should also be considered?

When the code action resolves, we can get the RecordInfo, so a useless extension RecordWildCards will not actually be inserted if RecordInfo is RecordInfoApp.
The only problem with the current code is that the title of the code action will display Expand record wildcard (needs extension: NamedFieldPuns) (when the extension does not exist in current file), no matter what it is RecordInfo.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess what I'm saying is that we shouldn't have any code actions where the RecordInfo is RecordInfoApp, since RecordInfoApp can't be a wildcard, and that's what the code action applies to?

, _kind = Just CodeActionKind_RefactorRewrite
, _diagnostics = Nothing
, _isPreferred = Nothing
Expand All @@ -167,15 +176,19 @@ codeActionResolveProvider ideState pId ca uri uid = do
record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve
-- We should never fail to render
rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record
let edits = [rendered]
<> maybeToList (pragmaEdit enabledExtensions pragma)
let shouldInsertNamedFieldPuns (RecordInfoApp _ _) = False
shouldInsertNamedFieldPuns _ = True
whenMaybe True x = x
whenMaybe False _ = Nothing
edits = [rendered]
<> maybeToList (whenMaybe (shouldInsertNamedFieldPuns record) (pragmaEdit enabledExtensions pragma))
pure $ ca & L.edit ?~ mkWorkspaceEdit edits
where
mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit
mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing

inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
inlayHintDotdotProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
nfp <- getNormalizedFilePathE uri
pragma <- getFirstPragma pId state nfp
runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
Expand All @@ -186,18 +199,18 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent
, uid <- RangeMap.elementsInRange range crCodeActions
, Just record <- [IntMap.lookup uid crCodeActionResolve] ]
-- Get the definition of each dotdot of record
locations = [ getDefinition nfp pos
locations = [ fmap (,record) (getDefinition nfp pos)
| record <- records
, pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ]
defnLocsList <- lift $ sequence locations
pure $ InL $ mapMaybe (mkInlayHints crr pragma) (zip defnLocsList records)
pure $ InL $ mapMaybe (mkInlayHint crr pragma) defnLocsList
where
mkInlayHints :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
mkInlayHints CRR {enabledExtensions, nameMap} pragma (defnLocs, record) =
mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
mkInlayHint CRR {enabledExtensions, nameMap} pragma (defnLocs, record) =
let range = recordInfoToDotDotRange record
textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record)
<> maybeToList (pragmaEdit enabledExtensions pragma)
names = renderRecordInfoAsLabelName record
names = renderRecordInfoAsDotdotLabelName record
in do
end <- fmap _end range
names' <- names
Expand All @@ -224,6 +237,40 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent
}
mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing


inlayHintPosRecProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
nfp <- getNormalizedFilePathE uri
runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
(CRR {crCodeActions, nameMap, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp
let records = [ record
| Just range <- [toCurrentRange pm visibleRange]
, uid <- RangeMap.elementsInRange range crCodeActions
, Just record <- [IntMap.lookup uid crCodeActionResolve] ]
pure $ InL (concatMap (mkInlayHints nameMap) records)
where
mkInlayHints :: UniqFM Name [Name] -> RecordInfo -> [InlayHint]
mkInlayHints nameMap record@(RecordInfoApp _ (RecordAppExpr _ fla)) =
let textEdits = renderRecordInfoAsTextEdit nameMap record
in mapMaybe (mkInlayHint textEdits) fla
mkInlayHints _ _ = []
mkInlayHint :: Maybe TextEdit -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint
mkInlayHint te (label, _) =
let (name, loc) = ((flSelector . unLoc) &&& (srcSpanToLocation . getLoc)) label
fieldDefLoc = srcSpanToLocation (nameSrcSpan name)
in do
(Location _ recRange) <- loc
pure InlayHint { _position = _start recRange
, _label = InR $ pure (mkInlayHintLabelPart name fieldDefLoc)
, _kind = Nothing -- neither a type nor a parameter
, _textEdits = Just (maybeToList te) -- same as CodeAction
, _tooltip = Just $ InL "Expand positional record" -- same as CodeAction
, _paddingLeft = Nothing
, _paddingRight = Nothing
, _data_ = Nothing
}
mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing

mkTitle :: [Extension] -> Text
mkTitle exts = "Expand record wildcard"
<> if NamedFieldPuns `elem` exts
Expand Down Expand Up @@ -303,6 +350,7 @@ data CollectRecordsResult = CRR

instance NFData CollectRecordsResult
instance NFData RecordInfo
instance NFData RecordAppExpr

instance Show CollectRecordsResult where
show _ = "<CollectRecordsResult>"
Expand All @@ -325,18 +373,25 @@ instance Show CollectNamesResult where

type instance RuleResult CollectNames = CollectNamesResult

data RecordAppExpr = RecordAppExpr (LHsExpr GhcTc) [(Located FieldLabel, HsExpr GhcTc)]
deriving (Generic)

data RecordInfo
= RecordInfoPat RealSrcSpan (Pat GhcTc)
| RecordInfoCon RealSrcSpan (HsExpr GhcTc)
| RecordInfoApp RealSrcSpan RecordAppExpr
deriving (Generic)

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

recordInfoToRange :: RecordInfo -> Range
recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss
recordInfoToRange (RecordInfoApp ss _) = realSrcSpanToRange ss

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

renderRecordInfoAsLabelName :: RecordInfo -> Maybe [Name]
renderRecordInfoAsLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat
renderRecordInfoAsLabelName (RecordInfoCon _ expr) = showRecordConFlds expr
renderRecordInfoAsDotdotLabelName :: RecordInfo -> Maybe [Name]
renderRecordInfoAsDotdotLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat
renderRecordInfoAsDotdotLabelName (RecordInfoCon _ expr) = showRecordConFlds expr
renderRecordInfoAsDotdotLabelName _ = Nothing


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

showRecordApp :: RecordAppExpr -> Maybe Text
showRecordApp (RecordAppExpr recConstr fla)
= Just $ printOutputable recConstr <> " { "
<> T.intercalate ", " (showFieldWithArg <$> fla)
<> " }"
where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg

collectRecords :: GenericQ [RecordInfo]
collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
Expand Down Expand Up @@ -504,6 +567,23 @@ getRecCons e@(unLoc -> RecordCon _ _ flds)
mkRecInfo :: LHsExpr GhcTc -> [RecordInfo]
mkRecInfo expr =
[ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]]
getRecCons expr@(unLoc -> app@(HsApp _ _ _)) =
let fieldss = maybeToList $ getFields app []
recInfo = concatMap mkRecInfo fieldss
in (recInfo, not (null recInfo))
where
mkRecInfo :: RecordAppExpr -> [RecordInfo]
mkRecInfo appExpr =
[ RecordInfoApp realSpan' appExpr | RealSrcSpan realSpan' _ <- [ getLoc expr ] ]

getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr
getFields (HsApp _ constr@(unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) arg) args
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think you can just guard this case with | not (null fls) and then delete the case above, since the fallthrough case will handle it?

| not (null fls)
= Just (RecordAppExpr constr labelWithArgs)
where labelWithArgs = zipWith mkLabelWithArg fls (arg : args)
mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg)
getFields (HsApp _ constr arg) args = getFields (unLoc constr) (arg : args)
getFields _ _ = Nothing
getRecCons _ = ([], False)

getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool)
Expand Down
Loading
Loading