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 ff436c61fc..137965ed92 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 @@ -56,6 +56,7 @@ import Development.IDE.GHC.Compat (FieldLabel (flSelector), HsExpr (HsApp, HsVar, XExpr), HsFieldBind (hfbLHS), HsRecFields (..), + HsWrap (HsWrap), Identifier, LPat, Located, NamedThing (getName), @@ -577,13 +578,19 @@ getRecCons expr@(unLoc -> app@(HsApp _ _ _)) = [ RecordInfoApp realSpan' appExpr | RealSrcSpan realSpan' _ <- [ getLoc expr ] ] getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr - getFields (HsApp _ constr@(unLoc -> (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _))) arg) args + getFields (HsApp _ constr@(unLoc -> expr) arg) args | not (null fls) = Just (RecordAppExpr constr labelWithArgs) - where labelWithArgs = zipWith mkLabelWithArg fls (arg : args) + where fls = getExprFields expr + 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 + + getExprFields :: HsExpr GhcTc -> [FieldLabel] + getExprFields (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _)) = fls + getExprFields (XExpr (WrapExpr (HsWrap _ expr))) = getExprFields expr + getExprFields _ = [] 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 a2d980ab50..1a4fa5d2ba 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 + , mkTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15 ] , testGroup "inlay hints" [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do @@ -212,6 +213,31 @@ test = testGroup "explicit-fields" , _tooltip = Just $ InL "Expand record wildcard" , _paddingLeft = Just True }] + , mkInlayHintsTest "PolymorphicRecordConstruction" Nothing 15 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PolymorphicRecordConstruction" + 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 + } + ] ] ] @@ -285,10 +311,10 @@ mkLabelPart offset fp line start value = do uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) location uri line char = Location uri (Range (Position line char) (Position line (char + offset value))) -mkLabelPartOffsetLength ::FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLength :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart mkLabelPartOffsetLength = mkLabelPart (fromIntegral . T.length) -mkLabelPartOffsetLengthSub1 ::FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLengthSub1 :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart mkLabelPartOffsetLengthSub1 = mkLabelPart (fromIntegral . subtract 1 . T.length) commaPart :: InlayHintLabelPart diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs new file mode 100644 index 0000000000..f289508524 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PolymorphicRecordConstruction where + +data MyRec m = 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/PolymorphicRecordConstruction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs new file mode 100644 index 0000000000..f8b9791da5 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PolymorphicRecordConstruction where + +data MyRec m = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec () +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec a b c