Implement Reviews

Author: vidit-od

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

@@ -19,6 +19,7 @@ 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
@@ -27,7 +28,6 @@ import           Data.List                            (find, intersperse,
 import qualified Data.Map                             as Map
 import           Data.Maybe                           (fromMaybe, isJust,
                                                        mapMaybe, maybeToList)
-import           Data.Ord                             (Down (..))
 import           Data.Text                            (Text)
 import qualified Data.Text                            as T
 import           Data.Unique                          (hashUnique, newUnique)
@@ -165,12 +165,13 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do
                       -- converted to the record syntax through the code action
                       , isConvertible record
                       ]
-      sortedRecords = sortOn (Down . recordDepth recordsWithUid . snd) recordsWithUid
+      recordsOnly = map snd recordsWithUid
+      sortedRecords = sortOn (recordDepth recordsOnly . snd) recordsWithUid
   pure $ InL $ case sortedRecords of
-    (top : _) -> [mkCodeAction enabledExtensions top]
+    (top : _) -> [mkCodeAction enabledExtensions (fst top)]
     []        -> []
   where
-    mkCodeAction exts (uid, _record) = InR CodeAction
+    mkCodeAction exts uid = InR CodeAction
       { _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp
       , _kind = Just CodeActionKind_RefactorRewrite
       , _diagnostics = Nothing
@@ -303,10 +304,12 @@ mkTitle exts = "Expand record wildcard"
                    then mempty
                    else " (needs extension: NamedFieldPuns)"
 
-recordDepth :: [(Int, RecordInfo)] -> RecordInfo -> Int
+-- 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 r = recordInfoToRange record
-  in length [ ()| (_, other) <- allRecords, let r' = recordInfoToRange other, subRange r' r]
+  let isSubrangeOf = subRange `on` recordInfoToRange
+  in length $ filter (`isSubrangeOf` record) allRecords
 
 pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
 pragmaEdit exts pragma = if NamedFieldPuns `elem` exts

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

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/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