Cursor aware record expansion

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

@@ -19,10 +19,12 @@ import           Control.Monad.IO.Class               (MonadIO (liftIO))
 import           Control.Monad.Trans.Class            (lift)
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson                           (ToJSON (toJSON))
+import           Data.Function                        (on)
 import           Data.Generics                        (GenericQ, everything,
                                                        everythingBut, extQ, mkQ)
 import qualified Data.IntMap.Strict                   as IntMap
-import           Data.List                            (find, intersperse)
+import           Data.List                            (find, intersperse,
+                                                       sortOn)
 import qualified Data.Map                             as Map
 import           Data.Maybe                           (fromMaybe, isJust,
                                                        mapMaybe, maybeToList)
@@ -99,6 +101,7 @@ import           Ide.Plugin.Error                     (PluginError (PluginIntern
 import           Ide.Plugin.RangeMap                  (RangeMap)
 import qualified Ide.Plugin.RangeMap                  as RangeMap
 import           Ide.Plugin.Resolve                   (mkCodeActionWithResolveAndCommand)
+import           Ide.PluginUtils                      (subRange)
 import           Ide.Types                            (PluginDescriptor (..),
                                                        PluginId (..),
                                                        PluginMethodHandler,
@@ -111,7 +114,7 @@ import           Language.LSP.Protocol.Message        (Method (..),
 import           Language.LSP.Protocol.Types          (CodeAction (..),
                                                        CodeActionKind (CodeActionKind_RefactorRewrite),
                                                        CodeActionParams (CodeActionParams),
-                                                       Command, InlayHint (..),
+                                                       InlayHint (..),
                                                        InlayHintLabelPart (InlayHintLabelPart),
                                                        InlayHintParams (InlayHintParams, _range, _textDocument),
                                                        TextDocumentIdentifier (TextDocumentIdentifier),
@@ -155,17 +158,19 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
   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 recordsWithUid = [ (uid, 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
                       ]
-  let actions = map (mkCodeAction enabledExtensions) recordUids
-  pure $ InL actions
+      recordsOnly = map snd recordsWithUid
+      sortedRecords = sortOn (recordDepth recordsOnly . snd) recordsWithUid
+  pure $ InL $ case sortedRecords of
+    (top : _) -> [mkCodeAction enabledExtensions (fst top)]
+    []        -> []
   where
-    mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
     mkCodeAction exts uid = InR CodeAction
       { _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
       , _kind = Just CodeActionKind_RefactorRewrite
@@ -266,9 +271,12 @@ 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)) =
-       let textEdits = renderRecordInfoAsTextEdit nameMap record
-       in mapMaybe (mkInlayHint textEdits pm) fla
+     mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr sat _ fla)) =
+       -- Only create inlay hints for fully saturated constructors
+       case sat of
+         Saturated -> let textEdits = renderRecordInfoAsTextEdit nameMap record
+                      in mapMaybe (mkInlayHint textEdits pm) fla
+         Unsaturated -> []
      mkInlayHints _ _ _ = []
 
      mkInlayHint :: Maybe TextEdit -> PositionMapping -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint
@@ -296,6 +304,12 @@ mkTitle exts = "Expand record wildcard"
                    then mempty
                    else " (needs extension: NamedFieldPuns)"
 
+-- 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.
+recordDepth :: [RecordInfo] -> RecordInfo -> Int
+recordDepth allRecords record =
+  let isSubrangeOf = subRange `on` recordInfoToRange
+  in length $ filter (`isSubrangeOf` record) allRecords
 
 pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
 pragmaEdit exts pragma = if NamedFieldPuns `elem` exts
@@ -602,7 +616,11 @@ getRecCons e@(unLoc -> RecordCon _ _ flds)
 getRecCons expr@(unLoc -> app@(HsApp _ _ _)) =
   let fieldss = maybeToList $ getFields app []
       recInfo = concatMap mkRecInfo fieldss
-  in (recInfo, not (null recInfo))
+  -- Search control for positional constructors.
+  -- True stops further (nested) searching; False allows recursive search.
+  -- Currently hardcoded to False to enable nested positional searches.
+  -- Use `in (recInfo, not (null recInfo))` to disable nested searching.
+  in (recInfo, False)
   where
     mkRecInfo :: RecordAppExpr -> [RecordInfo]
     mkRecInfo appExpr =

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

@@ -38,6 +38,8 @@ test = testGroup "explicit-fields"
     , 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
     ]
   , testGroup "inlay hints"
     [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do
@@ -292,6 +294,89 @@ test = testGroup "explicit-fields"
                          , _paddingLeft = Nothing
                          }
           ]
+    , mkInlayHintsTest "CursorRecords" Nothing 9 $ \ih -> do
+        let mkLabelPart' = mkLabelPartOffsetLength "CursorRecords"
+        a0  <- mkLabelPart' 3 14 "a0"
+        a1  <- mkLabelPart' 4 14 "a1"
+        a11 <- mkLabelPart' 4 25 "a11"
+        a2  <- mkLabelPart' 5 14 "a2"
+        a3  <- mkLabelPart' 6 14 "a3"
+        (@?=) ih
+          [ defInlayHint
+              { _position = Position 9 52
+              , _label = InR [ a3 ]
+              , _textEdits = Just [ mkLineTextEdit "L1 {l2 = L2 {l3 = L3 {l4 = L4 {..}, ..}, ..}, a3}" 9 5 53 ]
+              , _tooltip = Just $ InL "Expand record wildcard"
+              , _paddingLeft = Just True
+              , _paddingRight = Nothing
+              , _data_ = Nothing
+              }
+          , defInlayHint
+              { _position = Position 9 47
+              , _label = InR [ a2 ]
+              , _textEdits = Just [ mkLineTextEdit "L2 {l3 = L3 {l4 = L4 {..}, ..}, a2}" 9 14 48 ]
+              , _tooltip = Just $ InL "Expand record wildcard"
+              , _paddingLeft = Just True
+              , _paddingRight = Nothing
+              , _data_ = Nothing
+              }
+          , defInlayHint
+              { _position = Position 9 42
+              , _label = InR [ a1 , InlayHintLabelPart ", " Nothing Nothing Nothing , a11 ]
+              , _textEdits = Just [ mkLineTextEdit "L3 {l4 = L4 {..}, a1, a11}" 9 23 43 ]
+              , _tooltip = Just $ InL "Expand record wildcard"
+              , _paddingLeft = Just True
+              , _paddingRight = Nothing
+              , _data_ = Nothing
+              }
+          , defInlayHint
+              { _position = Position 9 37
+              , _label = InR [ a0 ]
+              , _textEdits = Just [ mkLineTextEdit "L4 {a0}" 9 31 38 ]
+              , _tooltip = Just $ InL "Expand record wildcard"
+              , _paddingLeft = Just True
+              , _paddingRight = Nothing
+              , _data_ = Nothing
+              }
+          ]
+    , mkInlayHintsTest "CursorPositional" Nothing 15 $ \ih -> do
+        let mkLabelPart' = mkLabelPartOffsetLengthSub1 "CursorPositional"
+        middle <- mkLabelPart' 2 2 "middle="
+        inner  <- mkLabelPart' 6 2 "inner="
+        foo    <- mkLabelPart' 10 2 "foo="
+        bar    <- mkLabelPart' 11 4 "bar="
+        (@?=) ih
+          [ defInlayHint
+              { _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"
+              , _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"
+              , _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"
+              , _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"
+              , _paddingLeft = Nothing
+              }
+          ]
     ]
   ]
 

plugins/hls-explicit-record-fields-plugin/test/testdata/CursorPositional.expected.hs

@@ -0,0 +1,16 @@
+module CursorPositional where
+data RecOuter = RecOuter{
+  middle :: RecMiddle
+}
+
+data RecMiddle = RecMiddle {
+  inner :: RecInner
+}
+
+data RecInner = RecInner{
+  foo   :: Char
+  , bar :: Int
+}
+
+ex :: RecOuter
+ex = RecOuter (RecMiddle (RecInner { foo = 'c', bar = 42 }))

plugins/hls-explicit-record-fields-plugin/test/testdata/CursorPositional.hs

@@ -0,0 +1,16 @@
+module CursorPositional where
+data RecOuter = RecOuter{
+  middle :: RecMiddle
+}
+
+data RecMiddle = RecMiddle {
+  inner :: RecInner
+}
+
+data RecInner = RecInner{
+  foo   :: Char
+  , bar :: Int
+}
+
+ex :: RecOuter
+ex = RecOuter (RecMiddle (RecInner 'c' 42))

plugins/hls-explicit-record-fields-plugin/test/testdata/CursorRecords.expected.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE RecordWildCards #-}
+module CursorRecords where
+
+data L4 = L4{ a0 :: Int}
+data L3 = L3{ a1 :: Int, a11 :: Int, l4 :: L4}
+data L2 = L2{ a2 :: Int, l3 :: L3}
+data L1 = L1{ a3 :: Int, l2 :: L2}
+
+test :: L1 -> Int
+test L1 {l2 = L2{ l3 = L3 {l4 = L4 {..}, a1, a11}, ..}, ..} =
+    a0 + a1 + a2 + a3 + a11

plugins/hls-explicit-record-fields-plugin/test/testdata/CursorRecords.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE RecordWildCards #-}
+module CursorRecords where
+
+data L4 = L4{ a0 :: Int}
+data L3 = L3{ a1 :: Int, a11 :: Int, l4 :: L4}
+data L2 = L2{ a2 :: Int, l3 :: L3}
+data L1 = L1{ a3 :: Int, l2 :: L2}
+
+test :: L1 -> Int
+test L1 {l2 = L2{ l3 = L3{l4 = L4 {..}, ..}, ..}, ..} =
+    a0 + a1 + a2 + a3 + a11