Distinguish between wildcard expansion and traditional record syntax conversion

Author: ozkutuk

plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs

@@ -114,7 +114,7 @@ import           Language.LSP.Protocol.Message        (Method (..),
 import           Language.LSP.Protocol.Types          (CodeAction (..),
                                                        CodeActionKind (CodeActionKind_RefactorRewrite),
                                                        CodeActionParams (CodeActionParams),
-                                                       InlayHint (..),
+                                                       Command, InlayHint (..),
                                                        InlayHintLabelPart (InlayHintLabelPart),
                                                        InlayHintParams (InlayHintParams, _range, _textDocument),
                                                        TextDocumentIdentifier (TextDocumentIdentifier),
@@ -152,27 +152,45 @@ descriptor recorder plId =
   , pluginRules = collectRecordsRule recorder *> collectNamesRule
   }
 
+data RecordConversionType
+  = RecordWildcardExpansion
+  | RecordTraditionalSyntaxConversion
+
+data RecordConversion =
+  RecordConversion
+    Int -- ^ uid
+    RecordConversionType
+
+-- | Given a record, determine whether it is a case of wildcard expansion
+-- or a conversion to the traditional record syntax.
+getConversionType :: RecordInfo -> Maybe RecordConversionType
+getConversionType = \case
+  -- Only fully saturated constructor applications can be converted to
+  -- the record syntax through the code action
+  RecordInfoApp _ (RecordAppExpr Unsaturated _ _) -> Nothing
+  RecordInfoApp {} -> Just RecordTraditionalSyntaxConversion
+  _ -> Just RecordWildcardExpansion
+
 codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
 codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
   nfp <- getNormalizedFilePathE (docId ^. L.uri)
   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 recordsWithUid = [ (uid, record)
+  let recordsWithUid = [ (RecordConversion uid conversionType, record)
                       | 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
+                      , Just conversionType <- [getConversionType record]
                       ]
       recordsOnly = map snd recordsWithUid
       sortedRecords = sortOn (recordDepth recordsOnly . snd) recordsWithUid
   pure $ InL $ case sortedRecords of
     (top : _) -> [mkCodeAction enabledExtensions (fst top)]
     []        -> []
   where
-    mkCodeAction exts uid = InR CodeAction
-      { _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
+    mkCodeAction :: [Extension] -> RecordConversion -> Command |? CodeAction
+    mkCodeAction exts (RecordConversion uid conversionType) = InR CodeAction
+      { _title = mkTitle exts conversionType
       , _kind = Just CodeActionKind_RefactorRewrite
       , _diagnostics = Nothing
       , _isPreferred = Nothing
@@ -182,11 +200,6 @@ 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
@@ -251,7 +264,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen
                           , _label = InR label
                           , _kind = Nothing -- neither a type nor a parameter
                           , _textEdits = Just textEdits -- same as CodeAction
-                          , _tooltip = Just $ InL (mkTitle enabledExtensions) -- same as CodeAction
+                          , _tooltip = Just $ InL (mkTitle enabledExtensions RecordWildcardExpansion) -- same as CodeAction
                           , _paddingLeft = Just True -- padding after dotdot
                           , _paddingRight = Nothing
                           , _data_ = Nothing
@@ -290,19 +303,23 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
                         , _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
+                        , _tooltip = Just $ InL (mkTitle [] RecordTraditionalSyntaxConversion) -- same as CodeAction
                         , _paddingLeft = Nothing
                         , _paddingRight = Nothing
                         , _data_ = Nothing
                         }
 
      mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing
 
-mkTitle :: [Extension] -> Text
-mkTitle exts = "Expand record wildcard"
-                <> if NamedFieldPuns `elem` exts
-                   then mempty
-                   else " (needs extension: NamedFieldPuns)"
+mkTitle :: [Extension] -> RecordConversionType -> Text
+mkTitle exts = \case
+  RecordWildcardExpansion ->
+    "Expand record wildcard"
+      <> if NamedFieldPuns `elem` exts
+         then mempty
+         else " (needs extension: NamedFieldPuns)"
+  RecordTraditionalSyntaxConversion ->
+    "Convert to traditional record syntax"
 
 -- Calculate the nesting depth of a record by counting how many other records
 -- contain it. Used to prioritize more deeply nested records in code actions.

plugins/hls-explicit-record-fields-plugin/test/Main.hs

@@ -22,24 +22,24 @@ plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields"
 test :: TestTree
 test = testGroup "explicit-fields"
   [ testGroup "code actions"
-    [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20
-    , mkTest "Unused" "Unused" 12 10 12 20
-    , mkTest "Unused2" "Unused2" 12 10 12 20
-    , mkTest "WithPun" "WithPun" 13 10 13 25
-    , 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
+    [ mkExpansionTest "WildcardOnly" "WildcardOnly" 12 10 12 20
+    , mkExpansionTest "Unused" "Unused" 12 10 12 20
+    , mkExpansionTest "Unused2" "Unused2" 12 10 12 20
+    , mkExpansionTest "WithPun" "WithPun" 13 10 13 25
+    , mkExpansionTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32
+    , mkExpansionTest "Mixed" "Mixed" 14 10 14 37
+    , mkExpansionTest "Construction" "Construction" 16 5 16 15
+    , mkConversionTest "PositionalConstruction" "PositionalConstruction" 15 5 15 15
+    , mkExpansionTest "HsExpanded1" "HsExpanded1" 17 10 17 20
+    , mkExpansionTest "HsExpanded2" "HsExpanded2" 23 10 23 22
     , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52
     , 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
-    , mkTest "CursorAwarePositional" "CursorPositional" 15 26 15 34
-    , mkTest "CursorAwareRecords" "CursorRecords" 9 40 9 40
+    , mkConversionTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15
+    , mkConversionTest "CursorAwarePositional" "CursorPositional" 15 26 15 34
+    , mkExpansionTest "CursorAwareRecords" "CursorRecords" 9 40 9 40
     ]
   , testGroup "inlay hints"
     [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do
@@ -86,19 +86,19 @@ test = testGroup "explicit-fields"
           [ 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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _paddingLeft = Nothing
                          }
           ]
@@ -111,19 +111,19 @@ test = testGroup "explicit-fields"
           [ 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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _paddingLeft = Nothing
                          }
           ]
@@ -144,7 +144,7 @@ test = testGroup "explicit-fields"
           [defInlayHint { _position = Position 13 21
                         , _label = InR [ foo ]
                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]
-                        , _tooltip = Just $ InL "Expand positional record"
+                        , _tooltip = Just $ InL "Convert to traditional record syntax"
                         , _paddingLeft = Nothing
                         }]
     , mkInlayHintsTest "HsExpanded1DuplicateRecordFields" (Just " (positional)") 13 $ \ih -> do
@@ -154,7 +154,7 @@ test = testGroup "explicit-fields"
           [defInlayHint { _position = Position 13 21
                         , _label = InR [ foo ]
                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]
-                        , _tooltip = Just $ InL "Expand positional record"
+                        , _tooltip = Just $ InL "Convert to traditional record syntax"
                         , _paddingLeft = Nothing
                         }]
     , mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do
@@ -174,7 +174,7 @@ test = testGroup "explicit-fields"
           [defInlayHint { _position = Position 16 21
                         , _label = InR [ foo ]
                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 16 15 22 ]
-                        , _tooltip = Just $ InL "Expand positional record"
+                        , _tooltip = Just $ InL "Convert to traditional record syntax"
                         , _paddingLeft = Nothing
                         }]
     , mkInlayHintsTest "Mixed" Nothing 14 $ \ih -> do
@@ -278,19 +278,19 @@ test = testGroup "explicit-fields"
           [ 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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _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"
+                         , _tooltip = Just $ InL "Convert to traditional record syntax"
                          , _paddingLeft = Nothing
                          }
           ]
@@ -350,30 +350,30 @@ test = testGroup "explicit-fields"
               { _position = Position 15 14
               , _label = InR [ middle ]
               , _textEdits = Just [ mkLineTextEdit "RecOuter { middle = (RecMiddle (RecInner 'c' 42)) }" 15 5 43 ]
-              , _tooltip = Just $ InL "Expand positional record"
+              , _tooltip = Just $ InL "Convert to traditional record syntax"
               , _paddingLeft = Nothing
               }
           , defInlayHint
               { _position = Position 15 25
               , _label = InR [ inner ]
               , _textEdits = Just [ mkLineTextEdit "RecMiddle { inner = (RecInner 'c' 42) }" 15 15 42 ]
-              , _tooltip = Just $ InL "Expand positional record"
+              , _tooltip = Just $ InL "Convert to traditional record syntax"
               , _paddingLeft = Nothing
               }
           , defInlayHint
               { _position = Position 15 35
               , _label = InR [ foo ]
               , _textEdits =
                   Just [ mkLineTextEdit "RecInner { foo = 'c', bar = 42 }" 15 26 41 ]
-              , _tooltip = Just $ InL "Expand positional record"
+              , _tooltip = Just $ InL "Convert to traditional record syntax"
               , _paddingLeft = Nothing
               }
           , defInlayHint
               { _position = Position 15 39
               , _label = InR [ bar ]
               , _textEdits =
                   Just [ mkLineTextEdit "RecInner { foo = 'c', bar = 42 }" 15 26 41 ]
-              , _tooltip = Just $ InL "Expand positional record"
+              , _tooltip = Just $ InL "Convert to traditional record syntax"
               , _paddingLeft = Nothing
               }
           ]
@@ -395,35 +395,47 @@ mkTestNoAction title fp x1 y1 x2 y2 =
   testCase title $
     runSessionWithServer def plugin (testDataDir </> "noop") $ do
       doc <- openDoc (fp <.> "hs") "haskell"
-      actions <- getExplicitFieldsActions doc x1 y1 x2 y2
+      actions <- getActions isExplicitFieldsCodeAction doc x1 y1 x2 y2
       liftIO $ actions @?= []
 
-mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
-mkTestWithCount cnt title fp x1 y1 x2 y2 =
+mkTestWithCountAndMessage :: (CodeAction -> Bool) -> Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkTestWithCountAndMessage msgPredicate cnt title fp x1 y1 x2 y2 =
   goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do
-    acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2
+    acts@(act:_) <- getActions msgPredicate doc x1 y1 x2 y2
     liftIO $ length acts @?= cnt
     executeCodeAction act
 
-mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
-mkTest = mkTestWithCount 1
+mkExpansionTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkExpansionTest = mkTestWithCountAndMessage isRecWildcardExpansionCodeAction 1
 
-getExplicitFieldsActions
-  :: TextDocumentIdentifier
+mkConversionTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkConversionTest = mkTestWithCountAndMessage isRecLiteralConversionCodeAction 1
+
+getActions
+  :: (CodeAction -> Bool) -> TextDocumentIdentifier
   -> UInt -> UInt -> UInt -> UInt
   -> Session [CodeAction]
-getExplicitFieldsActions doc x1 y1 x2 y2 =
-  findExplicitFieldsAction <$> getAndResolveCodeActions doc range
+getActions p doc x1 y1 x2 y2 =
+  findAction p <$> getAndResolveCodeActions doc range
   where
     range = Range (Position x1 y1) (Position x2 y2)
 
-findExplicitFieldsAction :: [a |? CodeAction] -> [CodeAction]
-findExplicitFieldsAction = filter isExplicitFieldsCodeAction . rights . map toEither
+findAction :: (CodeAction -> Bool) -> [a |? CodeAction] -> [CodeAction]
+findAction p = filter p . rights . map toEither
 
 isExplicitFieldsCodeAction :: CodeAction -> Bool
-isExplicitFieldsCodeAction CodeAction {_title} =
+isExplicitFieldsCodeAction act =
+  isRecWildcardExpansionCodeAction act
+    || isRecLiteralConversionCodeAction act
+
+isRecWildcardExpansionCodeAction :: CodeAction -> Bool
+isRecWildcardExpansionCodeAction CodeAction {_title} =
   "Expand record wildcard" `T.isPrefixOf` _title
 
+isRecLiteralConversionCodeAction :: CodeAction -> Bool
+isRecLiteralConversionCodeAction CodeAction {_title} =
+  "Convert to traditional record syntax" `T.isPrefixOf` _title
+
 defInlayHint :: InlayHint
 defInlayHint =
   InlayHint