Explicit record fields inlay hints for polymorphic records (#4510)

Co-authored-by: fendor <[email protected]>

Author: wczyz

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)

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

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 }

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