Distinguish between wildcard expansion and traditional record syntax conversion

Author: ozkutuk

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

@@ -149,25 +149,42 @@ 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 recordUids = [ uid
+  let recordUids = [ RecordConversion uid conversionType
                       | 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]
                       ]
   let actions = map (mkCodeAction enabledExtensions) recordUids
   pure $ InL actions
   where
-    mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
-    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
@@ -177,11 +194,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
@@ -246,7 +258,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
@@ -282,20 +294,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"
 
 pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
 pragmaEdit exts pragma = if NamedFieldPuns `elem` exts

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

@@ -22,22 +22,22 @@ 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
+    , mkConversionTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15
     ]
   , testGroup "inlay hints"
     [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do
@@ -84,19 +84,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
                          }
           ]
@@ -109,19 +109,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
                          }
           ]
@@ -142,7 +142,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
@@ -152,7 +152,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
@@ -172,7 +172,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
@@ -276,19 +276,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
                          }
           ]
@@ -310,35 +310,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