From 5898472880ed770be2fbaedfeae6993c54cfbd7b Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 9 Nov 2024 00:51:52 +0800 Subject: [PATCH 1/6] refactor --- .../src/Ide/Plugin/ExplicitFields.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 2ac8f8a692..4fa50ecc13 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -145,7 +145,7 @@ 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 , _kind = Just CodeActionKind_RefactorRewrite @@ -186,14 +186,14 @@ 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) From 9478b2c843f5e6d3029138dbc1d37d168a050e76 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 9 Nov 2024 00:53:15 +0800 Subject: [PATCH 2/6] Support record positional construction inlay hints --- .../src/Ide/Plugin/ExplicitFields.hs | 131 ++++++++++++++---- .../test/Main.hs | 100 +++++++++---- .../PositionalConstruction.expected.hs | 16 +++ .../test/testdata/PositionalConstruction.hs | 16 +++ 4 files changed, 214 insertions(+), 49 deletions(-) create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 4fa50ecc13..46b8ff7a32 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -12,23 +12,23 @@ 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 (..), @@ -36,28 +36,36 @@ import Development.IDE (IdeState, 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), @@ -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 } @@ -147,7 +156,7 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do where mkCodeAction :: [Extension] -> Int -> Command |? CodeAction mkCodeAction exts uid = InR CodeAction - { _title = mkTitle exts + { _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing @@ -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 @@ -197,7 +210,7 @@ inlayHintProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdent 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 @@ -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 -- padding after dotdot + , _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 @@ -303,6 +350,7 @@ data CollectRecordsResult = CRR instance NFData CollectRecordsResult instance NFData RecordInfo +instance NFData RecordAppExpr instance Show CollectRecordsResult where show _ = "" @@ -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 @@ -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 @@ -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) @@ -493,17 +556,35 @@ getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch -#if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) -#else + + + getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) -#endif + getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where 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 _ (unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) _) _ + | null fls = Nothing + getFields (HsApp _ constr@(unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) arg) args + = 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) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index fdfbe4528c..a2d980ab50 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -29,6 +29,7 @@ test = testGroup "explicit-fields" , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "PositionalConstruction" "PositionalConstruction" 15 5 15 15 , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 @@ -37,8 +38,8 @@ test = testGroup "explicit-fields" , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 ] , testGroup "inlay hints" - [ mkInlayHintsTest "Construction" 16 $ \ih -> do - let mkLabelPart' = mkLabelPart "Construction" + [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Construction" foo <- mkLabelPart' 13 6 "foo" bar <- mkLabelPart' 14 6 "bar" baz <- mkLabelPart' 15 6 "baz" @@ -54,8 +55,33 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }] - , mkInlayHintsTest "HsExpanded1" 17 $ \ih -> do - let mkLabelPart' = mkLabelPart "HsExpanded1" + , mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction" + foo <- mkLabelPart' 5 4 "foo=" + bar <- mkLabelPart' 6 4 "bar=" + baz <- mkLabelPart' 7 4 "baz=" + (@?=) ih + [ defInlayHint { _position = Position 15 11 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 13 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 15 + , _label = InR [ baz ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + ] + , mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1" foo <- mkLabelPart' 11 4 "foo" (@?=) ih [defInlayHint { _position = Position 17 19 @@ -64,8 +90,18 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard" , _paddingLeft = Just True }] - , mkInlayHintsTest "HsExpanded2" 23 $ \ih -> do - let mkLabelPart' = mkLabelPart "HsExpanded2" + , mkInlayHintsTest "HsExpanded1" (Just " (positional)") 13 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1" + foo <- mkLabelPart' 11 4 "foo=" + (@?=) ih + [defInlayHint { _position = Position 13 21 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + }] + , mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded2" bar <- mkLabelPart' 14 4 "bar" (@?=) ih [defInlayHint { _position = Position 23 21 @@ -74,8 +110,18 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard" , _paddingLeft = Just True }] - , mkInlayHintsTest "Mixed" 14 $ \ih -> do - let mkLabelPart' = mkLabelPart "Mixed" + , mkInlayHintsTest "HsExpanded2" (Just " (positional)") 16 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded2" + foo <- mkLabelPart' 11 4 "foo=" + (@?=) ih + [defInlayHint { _position = Position 16 21 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 16 15 22 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + }] + , mkInlayHintsTest "Mixed" Nothing 14 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Mixed" baz <- mkLabelPart' 9 4 "baz" quux <- mkLabelPart' 10 4 "quux" (@?=) ih @@ -87,8 +133,8 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard" , _paddingLeft = Just True }] - , mkInlayHintsTest "Unused" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "Unused" + , mkInlayHintsTest "Unused" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Unused" foo <- mkLabelPart' 6 4 "foo" bar <- mkLabelPart' 7 4 "bar" baz <- mkLabelPart' 8 4 "baz" @@ -104,8 +150,8 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }] - , mkInlayHintsTest "Unused2" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "Unused2" + , mkInlayHintsTest "Unused2" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Unused2" foo <- mkLabelPart' 6 4 "foo" bar <- mkLabelPart' 7 4 "bar" baz <- mkLabelPart' 8 4 "baz" @@ -121,8 +167,8 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }] - , mkInlayHintsTest "WildcardOnly" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "WildcardOnly" + , mkInlayHintsTest "WildcardOnly" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WildcardOnly" foo <- mkLabelPart' 6 4 "foo" bar <- mkLabelPart' 7 4 "bar" baz <- mkLabelPart' 8 4 "baz" @@ -138,8 +184,8 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }] - , mkInlayHintsTest "WithExplicitBind" 12 $ \ih -> do - let mkLabelPart' = mkLabelPart "WithExplicitBind" + , mkInlayHintsTest "WithExplicitBind" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WithExplicitBind" bar <- mkLabelPart' 7 4 "bar" baz <- mkLabelPart' 8 4 "baz" (@?=) ih @@ -153,8 +199,8 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" , _paddingLeft = Just True }] - , mkInlayHintsTest "WithPun" 13 $ \ih -> do - let mkLabelPart' = mkLabelPart "WithPun" + , mkInlayHintsTest "WithPun" Nothing 13 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WithPun" bar <- mkLabelPart' 8 4 "bar" baz <- mkLabelPart' 9 4 "baz" (@?=) ih @@ -169,9 +215,9 @@ test = testGroup "explicit-fields" ] ] -mkInlayHintsTest :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree -mkInlayHintsTest fp line assert = - testCase fp $ +mkInlayHintsTest :: FilePath -> Maybe TestName -> UInt -> ([InlayHint] -> Assertion) -> TestTree +mkInlayHintsTest fp postfix line assert = + testCase (fp ++ concat postfix) $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc (fp ++ ".hs") "haskell" inlayHints <- getInlayHints doc (lineRange line) @@ -226,8 +272,8 @@ defInlayHint = , _data_ = Nothing } -mkLabelPart :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart -mkLabelPart fp line start value = do +mkLabelPart :: (Text -> UInt) -> FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPart offset fp line start value = do uri' <- uri pure $ InlayHintLabelPart { _location = Just (location uri' line start) , _value = value @@ -237,7 +283,13 @@ mkLabelPart fp line start value = do where toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) - location uri line char = Location uri (Range (Position line char) (Position line (char + (fromIntegral $ T.length value)))) + location uri line char = Location uri (Range (Position line char) (Position line (char + offset value))) + +mkLabelPartOffsetLength ::FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLength = mkLabelPart (fromIntegral . T.length) + +mkLabelPartOffsetLengthSub1 ::FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLengthSub1 = mkLabelPart (fromIntegral . subtract 1 . T.length) commaPart :: InlayHintLabelPart commaPart = diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs new file mode 100644 index 0000000000..667fc25fe0 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PositionalConstruction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec { foo = a, bar = b, baz = c } diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs new file mode 100644 index 0000000000..0b2f8d9f86 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PositionalConstruction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec a b c From 67187b5a419b6e0d3b01d06adce6c3eed6ea965a Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 11 Nov 2024 12:10:53 +0800 Subject: [PATCH 3/6] restore the missing conditional getRecCons that deleted by mistake --- .../src/Ide/Plugin/ExplicitFields.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 46b8ff7a32..3216c08399 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -556,11 +556,11 @@ getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch - - - +#if __GLASGOW_HASKELL__ >= 910 +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) +#else getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) - +#endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where From b7f110ff8cb3cc0fb90a3b840bbba9948691e1ac Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 11 Nov 2024 15:13:35 +0800 Subject: [PATCH 4/6] NFData FieldLabel when GHC < 906 --- ghcide/src/Development/IDE/GHC/Orphans.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 8d46d44445..2ee19beeb2 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -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 @@ -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] @@ -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 From d96cf67b295375a301faaceed2657bdcaf33afa8 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Dec 2024 01:59:14 +0800 Subject: [PATCH 5/6] chore: remove wrong comment --- .../src/Ide/Plugin/ExplicitFields.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 3216c08399..2982f2fb99 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -265,7 +265,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume , _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 -- padding after dotdot + , _paddingLeft = Nothing , _paddingRight = Nothing , _data_ = Nothing } From 07caefe1b221aed67d65e2f82ac9e12ff46646d3 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Dec 2024 02:04:31 +0800 Subject: [PATCH 6/6] refactor: simplify `getFields` case --- .../src/Ide/Plugin/ExplicitFields.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 2982f2fb99..ff436c61fc 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -577,9 +577,8 @@ getRecCons expr@(unLoc -> app@(HsApp _ _ _)) = [ RecordInfoApp realSpan' appExpr | RealSrcSpan realSpan' _ <- [ getLoc expr ] ] getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr - getFields (HsApp _ (unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) _) _ - | null fls = Nothing getFields (HsApp _ constr@(unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) arg) args + | not (null fls) = Just (RecordAppExpr constr labelWithArgs) where labelWithArgs = zipWith mkLabelWithArg fls (arg : args) mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg)