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 2d711979c3..be903ff924 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 @@ -151,10 +151,17 @@ descriptor recorder plId = codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) - CRR {crCodeActions, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + CRR {crCodeActions, crCodeActionResolve, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp -- All we need to build a code action is the list of extensions, and a int to -- allow us to resolve it later. - let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) + let recordUids = [ uid + | uid <- RangeMap.filterByRange range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] + -- Only fully saturated constructor applications can be + -- converted to the record syntax through the code action + , isConvertible record + ] + let actions = map (mkCodeAction enabledExtensions) recordUids pure $ InL actions where mkCodeAction :: [Extension] -> Int -> Command |? CodeAction @@ -169,6 +176,11 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do , _data_ = Just $ toJSON uid } + isConvertible :: RecordInfo -> Bool + isConvertible = \case + RecordInfoApp _ (RecordAppExpr Unsaturated _ _) -> False + _ -> True + codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve codeActionResolveProvider ideState pId ca uri uid = do nfp <- getNormalizedFilePathE uri @@ -253,7 +265,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume pure $ InL (concatMap (mkInlayHints nameMap pm) records) where mkInlayHints :: UniqFM Name [Name] -> PositionMapping -> RecordInfo -> [InlayHint] - mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr _ fla)) = + mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr _ _ fla)) = let textEdits = renderRecordInfoAsTextEdit nameMap record in mapMaybe (mkInlayHint textEdits pm) fla mkInlayHints _ _ _ = [] @@ -379,7 +391,16 @@ instance Show CollectNamesResult where type instance RuleResult CollectNames = CollectNamesResult -data RecordAppExpr = RecordAppExpr (LHsExpr GhcTc) [(Located FieldLabel, HsExpr GhcTc)] +data Saturated = Saturated | Unsaturated + deriving (Generic) + +instance NFData Saturated + +data RecordAppExpr + = RecordAppExpr + Saturated -- ^ Is the DataCon application fully saturated or partially applied? + (LHsExpr GhcTc) + [(Located FieldLabel, HsExpr GhcTc)] deriving (Generic) data RecordInfo @@ -391,7 +412,7 @@ data RecordInfo 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 (RecordInfoApp ss (RecordAppExpr _ _ fla)) = pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla) recordInfoToRange :: RecordInfo -> Range @@ -536,7 +557,7 @@ showRecordConFlds (RecordCon _ _ flds) = showRecordConFlds _ = Nothing showRecordApp :: RecordAppExpr -> Maybe Text -showRecordApp (RecordAppExpr recConstr fla) +showRecordApp (RecordAppExpr _ recConstr fla) = Just $ printOutputable recConstr <> " { " <> T.intercalate ", " (showFieldWithArg <$> fla) <> " }" @@ -588,8 +609,14 @@ getRecCons expr@(unLoc -> app@(HsApp _ _ _)) = getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr getFields (HsApp _ constr@(unLoc -> expr) arg) args - | not (null fls) - = Just (RecordAppExpr constr labelWithArgs) + | not (null fls) = Just $ + -- Code action is only valid if the constructor application is fully + -- saturated, but we still want to display the inlay hints for partially + -- applied constructors + RecordAppExpr + (if length fls <= length args + 1 then Saturated else Unsaturated) + constr + labelWithArgs where fls = getExprFields expr labelWithArgs = zipWith mkLabelWithArg fls (arg : args) mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 1a4fa5d2ba..da84fd76cb 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -36,6 +36,7 @@ test = testGroup "explicit-fields" , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + , mkTestNoAction "PartiallyAppliedCon" "PartiallyAppliedCon" 7 8 7 12 , mkTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15 ] , testGroup "inlay hints" diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/PartiallyAppliedCon.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/PartiallyAppliedCon.hs new file mode 100644 index 0000000000..2f6f52e30b --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/PartiallyAppliedCon.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Haskell2010 #-} + +module PartiallyAppliedCon where + +data T = MkT { fa :: Int, fb :: Char } + +foo :: Int -> Char -> T +foo x = MkT x