Implements michaelpj code review suggestions

Author: joyfulmantis

.github/workflows/test.yml

@@ -247,7 +247,7 @@ jobs:
 
       - if: matrix.test && matrix.ghc != '8.10.7' && matrix.ghc != '9.0.2'
         name: Test hls-overloaded-record-dot-plugin test suite
-        run: cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-retrie-plugin --test-options="$TEST_OPTS"
+        run: cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS"
 
 
 

CODEOWNERS

@@ -33,6 +33,7 @@
 /plugins/hls-tactics-plugin @isovector
 /plugins/hls-stan-plugin @uhbif19
 /plugins/hls-explicit-record-fields-plugin @ozkutuk
+/plugins/hls-overloaded-record-dot-plugin @joyfulmantis
 
 # Benchmarking
 /shake-bench @pepeiborra

ghcide/src/Development/IDE/GHC/Orphans.hs

@@ -236,3 +236,9 @@ instance NFData NodeKey where
 instance NFData HomeModLinkable where
   rnf = rwhnf
 #endif
+
+instance NFData (HsExpr (GhcPass 'Renamed)) where
+    rnf = rwhnf
+
+instance NFData Extension where
+  rnf = rwhnf

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

@@ -22,8 +22,8 @@ import           Data.Functor                    ((<&>))
 import           Data.Generics                   (GenericQ, everything, extQ,
                                                   mkQ)
 import qualified Data.HashMap.Strict             as HashMap
-import           Data.Maybe                      (isJust, listToMaybe,
-                                                  maybeToList, fromMaybe)
+import           Data.Maybe                      (fromMaybe, isJust,
+                                                  listToMaybe, maybeToList)
 import           Data.Text                       (Text)
 import           Development.IDE                 (IdeState, NormalizedFilePath,
                                                   Pretty (..), Recorder (..),
@@ -36,8 +36,8 @@ import           Development.IDE.Core.Shake      (define, use)
 import qualified Development.IDE.Core.Shake      as Shake
 import           Development.IDE.GHC.Compat      (HsConDetails (RecCon),
                                                   HsRecFields (..), LPat,
-                                                  Outputable, getLoc, unLoc,
-                                                  recDotDot)
+                                                  Outputable, getLoc, recDotDot,
+                                                  unLoc)
 import           Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns),
                                                   GhcPass,
                                                   HsExpr (RecordCon, rcon_flds),
@@ -103,7 +103,7 @@ codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
 codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do
   nfp <- getNormalizedFilePath (docId ^. L.uri)
   pragma <- getFirstPragma pId ideState nfp
-  CRR recMap (map unExt -> exts) <- collectRecords' ideState nfp
+  CRR recMap exts <- collectRecords' ideState nfp
   let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap)
   pure $ List actions
 
@@ -160,8 +160,8 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect
           pure ([], CRR <$> recMap <*> Just exts)
 
   where
-    getEnabledExtensions :: TcModuleResult -> [GhcExtension]
-    getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed
+    getEnabledExtensions :: TcModuleResult -> [Extension]
+    getEnabledExtensions =  getExtensions . tmrParsed
 
 getRecords :: TcModuleResult -> [RecordInfo]
 getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =
@@ -186,7 +186,7 @@ instance NFData CollectRecords
 
 data CollectRecordsResult = CRR
   { recordInfos       :: RangeMap RenderedRecordInfo
-  , enabledExtensions :: [GhcExtension]
+  , enabledExtensions :: [Extension]
   }
   deriving (Generic)
 
@@ -213,15 +213,8 @@ instance Show CollectNamesResult where
 
 type instance RuleResult CollectNames = CollectNamesResult
 
--- `Extension` is wrapped so that we can provide an `NFData` instance
--- (without resorting to creating an orphan instance).
-newtype GhcExtension = GhcExtension { unExt :: Extension }
-
-instance NFData GhcExtension where
-  rnf x = x `seq` ()
-
 -- As with `GhcExtension`, this newtype exists mostly to attach
--- an `NFData` instance to `UniqFM`.
+-- an `NFData` instance to `UniqFM`.(without resorting to creating an orphan instance).
 newtype NameMap = NameMap (UniqFM Name [Name])
 
 instance NFData NameMap where

plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal

@@ -41,6 +41,7 @@ library
       , ghc-boot-th
       , unordered-containers
       , containers
+      , deepseq
     hs-source-dirs:   src
     default-language: GHC2021
 

plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs

@@ -16,7 +16,8 @@ module Ide.Plugin.OverloadedRecordDot
 import           Control.Lens                   ((^.))
 import           Control.Monad.IO.Class         (MonadIO, liftIO)
 import           Control.Monad.Trans.Except     (ExceptT)
-import           Data.Generics                  (GenericQ, everything, mkQ)
+import           Data.Generics                  (GenericQ, everything,
+                                                 everythingBut, mkQ)
 import qualified Data.HashMap.Strict            as HashMap
 import           Data.Maybe                     (listToMaybe, maybeToList)
 import           Data.Text                      (Text)
@@ -37,11 +38,17 @@ import           Development.IDE.GHC.Compat     (HsExpr (HsRecSel))
 import           Development.IDE.GHC.Compat     (HsExpr (HsRecFld))
 #endif
 
+import           Control.DeepSeq                (rwhnf)
+import           Data.Bifunctor                 (Bifunctor (first))
 import           Development.IDE.GHC.Compat     (Extension (OverloadedRecordDot),
                                                  GhcPass,
-                                                 HsExpr (HsApp, HsPar, HsVar, OpApp),
+                                                 HsExpansion (HsExpanded),
+                                                 HsExpr (HsApp, HsPar, HsVar, OpApp, XExpr),
                                                  LHsExpr, Outputable, Pass (..),
-                                                 RealSrcSpan, getLoc, hs_valds,
+                                                 RealSrcSpan, appPrec,
+                                                 dollarName, getLoc, hs_valds,
+                                                 parenthesizeHsContext,
+                                                 parenthesizeHsExpr,
                                                  pattern RealSrcSpan, unLoc)
 import           Development.IDE.GHC.Util       (getExtensions, printOutputable)
 import           Development.IDE.Graph          (RuleResult)
@@ -71,168 +78,138 @@ import           Language.LSP.Types             (CodeAction (..),
                                                  normalizedFilePathToUri,
                                                  type (|?) (InR))
 import qualified Language.LSP.Types.Lens        as L
-
 data Log
   = LogShake Shake.Log
-  | LogCollectedRecordSelectors [RecordSelectors]
-  | LogRenderedRecordSelectors [ConvertedRecordSelector]
+  | LogCollectedRecordSelectors [RecordSelectorExpr]
+  | LogTextEdits [TextEdit]
 
 instance Pretty Log where
   pretty = \case
     LogShake shakeLog -> pretty shakeLog
     LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs
-    LogRenderedRecordSelectors recs -> "Rendered record selectors:" <+> pretty recs
 
 data CollectRecordSelectors = CollectRecordSelectors
                     deriving (Eq, Show, Generic)
 
 instance Hashable CollectRecordSelectors
 instance NFData CollectRecordSelectors
 
-data CollectConvertedRecordSelectorsResult = CCRSR
-  { recordInfos       :: RangeMap ConvertedRecordSelector
-  , enabledExtensions :: [GhcExtension]
+data CollectRecordSelectorsResult = CRSR
+  { recordInfos       :: RangeMap RecordSelectorExpr
+  , enabledExtensions :: [Extension]
   }
   deriving (Generic)
 
-instance NFData CollectConvertedRecordSelectorsResult
+instance NFData CollectRecordSelectorsResult
 
-instance Show CollectConvertedRecordSelectorsResult where
+instance Show CollectRecordSelectorsResult where
   show _ = "<CollectRecordsResult>"
 
-type instance RuleResult CollectRecordSelectors = CollectConvertedRecordSelectorsResult
-
--- `Extension` is wrapped so that we can provide an `NFData` instance
--- (without resorting to creating an orphan instance).
-newtype GhcExtension = GhcExtension { unExt :: Extension }
-
-instance NFData GhcExtension where
-  rnf x = x `seq` ()
+type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult
 
-data RecordSelectors
-  = RecordSelectors RealSrcSpan (HsExpr (GhcPass 'Renamed))
 
-instance Pretty RecordSelectors where
-  pretty (RecordSelectors ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)
-
-data ConvertedRecordSelector = ConvertedRecordSelector
-  { range              :: Range
-  , convertedDotRecord :: Text
-  }
-  deriving (Generic)
+data RecordSelectorExpr = RecordSelectorExpr { location     :: Range,
+                                               selectorExpr :: LHsExpr (GhcPass 'Renamed),
+                                               recordExpr   :: LHsExpr (GhcPass 'Renamed) }
 
-instance Pretty ConvertedRecordSelector where
-  pretty (ConvertedRecordSelector r cdr) = pretty (show r) <> ":" <+> pretty cdr
+instance Pretty RecordSelectorExpr where
+  pretty (RecordSelectorExpr l rs se) = pretty (printOutputable rs) <> ":" <+> pretty (printOutputable se)
 
-instance NFData ConvertedRecordSelector
+instance NFData RecordSelectorExpr where
+  rnf = rwhnf
 
 descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
   { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider
-  , pluginRules = collectConvRecSelsRule recorder
+  , pluginRules = collectRecSelsRule recorder
   }
 
 codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
 codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = pluginResponse $ do
   nfp <- getNormalizedFilePath (caDocId ^. L.uri)
   pragma <- getFirstPragma pId ideState nfp
-  CCRSR crsMap (coerce -> exts) <- collectConvRecSels' ideState nfp
-  let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange caRange crsMap)
+  CRSR crsMap exts <- collectRecSelResult ideState nfp
+  let
+    pragmaEdit = if OverloadedRecordDot `elem` exts
+                            then Nothing
+                            else Just $ insertNewPragma pragma OverloadedRecordDot
+    edits crs = maybeToList (convertRecordSelectors crs) <> maybeToList pragmaEdit
+    changes crs = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List (edits crs))
+    mkCodeAction crs = InR CodeAction
+        { _title = mkCodeActionTitle exts crs
+        , _kind = Just CodeActionRefactorRewrite
+        , _diagnostics = Nothing
+        , _isPreferred = Nothing
+        , _disabled = Nothing
+        , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing
+        , _command = Nothing
+        , _xdata = Nothing
+        }
+    actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)
   pure $ List actions
   where
-    mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> ConvertedRecordSelector -> Command |? CodeAction
-    mkCodeAction nfp exts pragma crs = InR CodeAction
-      { _title = mkCodeActionTitle exts
-      , _kind = Just CodeActionRefactorRewrite
-      , _diagnostics = Nothing
-      , _isPreferred = Nothing
-      , _disabled = Nothing
-      , _edit = Just $ mkWorkspaceEdit nfp edits
-      , _command = Nothing
-      , _xdata = Nothing
-      }
-      where
-        edits = mkTextEdit crs : maybeToList pragmaEdit
-
-        mkTextEdit :: ConvertedRecordSelector -> TextEdit
-        mkTextEdit (ConvertedRecordSelector r cdr) = TextEdit r cdr
-
-        pragmaEdit :: Maybe TextEdit
-        pragmaEdit = if OverloadedRecordDot `elem` exts
-                       then Nothing
-                       else Just $ insertNewPragma pragma OverloadedRecordDot
-
-    mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
-    mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing
-      where
-        changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits)
-
-    mkCodeActionTitle :: [Extension] -> Text
-    mkCodeActionTitle exts =
+    mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text
+    mkCodeActionTitle exts (RecordSelectorExpr _ se _) =
       if OverloadedRecordDot `elem` exts
         then title
         else title <> " (needs extension: OverloadedRecordDot)"
         where
-          title = "Convert to record dot syntax"
+          title = "Convert `" <> name <> "` to record dot syntax"
+          name = printOutputable se
 
-collectConvRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
-collectConvRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecordSelectors nfp ->
+collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
+collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecordSelectors nfp ->
   use TypeCheck nfp >>= \case
     Nothing -> pure ([], Nothing)
     Just tmr -> do
       let exts = getEnabledExtensions tmr
           recSels = getRecordSelectors tmr
       logWith recorder Debug (LogCollectedRecordSelectors recSels)
-      let convertedRecordSelectors = traverse convertRecordSelectors recSels
-          crsMap = RangeMap.fromList range <$> convertedRecordSelectors
-      logWith recorder Debug (LogRenderedRecordSelectors (concat convertedRecordSelectors))
-      pure ([], CCRSR <$> crsMap <*> Just exts)
+      let crsMap :: RangeMap RecordSelectorExpr
+          crsMap = RangeMap.fromList location recSels
+      pure ([], CRSR <$> Just crsMap <*> Just exts)
   where
-    getEnabledExtensions :: TcModuleResult -> [GhcExtension]
-    getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed
+    getEnabledExtensions :: TcModuleResult -> [Extension]
+    getEnabledExtensions = getExtensions . tmrParsed
 
-getRecordSelectors :: TcModuleResult -> [RecordSelectors]
+getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]
 getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =
     collectRecordSelectors valBinds
 
-convertRecordSelectors :: RecordSelectors -> Maybe ConvertedRecordSelector
-convertRecordSelectors (RecordSelectors ss expr) = ConvertedRecordSelector (realSrcSpanToRange ss) <$> convertRecSel expr
+convertRecordSelectors :: RecordSelectorExpr -> Maybe TextEdit
+convertRecordSelectors (RecordSelectorExpr l  se re) = TextEdit l <$> convertRecSel se re
 
-convertRecSel :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text
-convertRecSel (HsApp _ s r) =
-    Just $ printOutputable r <> "." <> printOutputable s
-convertRecSel ( OpApp _ s _ r) =
-    Just $ "(" <> printOutputable r <> ")." <> printOutputable s
-convertRecSel _ = Nothing
+convertRecSel :: Outputable (LHsExpr (GhcPass 'Renamed)) => LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> Maybe Text
+convertRecSel se re =
+    Just $ printOutputable (parenthesizeHsExpr appPrec re) <> "." <> printOutputable se
 
-collectRecordSelectors :: GenericQ [RecordSelectors]
-collectRecordSelectors = everything (<>) (maybeToList . (Nothing `mkQ` getRecSels))
+-- It's important that we use everthingBut here, because if we used everything we would
+-- get duplicates for every case that occures inside a HsExpanded expression.
+collectRecordSelectors :: GenericQ [RecordSelectorExpr]
+collectRecordSelectors = everythingBut (<>) (first maybeToList. ((Nothing, False) `mkQ` getRecSels))
 
+getRecSels :: LHsExpr (GhcPass 'Renamed) -> (Maybe RecordSelectorExpr, Bool)
+-- When we stumble upon an occurance of HsExpanded, we only want to follow one branch
+-- we do this here, by explicitly returning an occurance from traversing the original branch,
+-- and returning True, which keeps syb from implicitly continuing to traverse.
+getRecSels (unLoc -> XExpr (HsExpanded a _)) = (listToMaybe $ collectRecordSelectors a, True)
 #if __GLASGOW_HASKELL__ >= 903
-getRecSels :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordSelectors
--- standard record selection: "field record"
-getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsVar _ _)) =
-  listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
--- Record selection where the field is being applied to a parenthesised expression: "field (record)"
-getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsPar _ _ _ _)) =
-  listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
+-- applied record selection: "field record" or "field (record)" or "field field.record"
+getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) =
+  (listToMaybe [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re | RealSrcSpan realSpan' _ <- [ getLoc e ]], False)
 -- Record selection where the field is being applied with the "$" operator: "field $ record"
-getRecSels e@(unLoc -> OpApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsVar _ (unLoc -> d)) _)
-    | printOutputable d == "$" = listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
-getRecSels _ = Nothing
+getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) (unLoc -> HsVar _ (unLoc -> d)) re)
+    | d == dollarName = (listToMaybe [ RecordSelectorExpr (realSrcSpanToRange realSpan')  se re | RealSrcSpan realSpan' _ <- [ getLoc e ]], False)
 #else
-getRecSels :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordSelectors
-getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecFld _ _) (unLoc -> HsVar _ _)) =
-  listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
-getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecFld _ _) (unLoc -> HsPar _ _)) =
-  listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
-getRecSels e@(unLoc -> OpApp _ (unLoc -> HsRecFld _ _) (unLoc -> HsVar _ (unLoc -> d)) _)
-    | printOutputable d == "$" = listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]]
-getRecSels _ = Nothing
+getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) =
+  (listToMaybe [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re | RealSrcSpan realSpan' _ <- [ getLoc e ]], False)
+getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) (unLoc -> HsVar _ (unLoc -> d)) re)
+    | d == dollarName = (listToMaybe [ RecordSelectorExpr (realSrcSpanToRange realSpan')  se re | RealSrcSpan realSpan' _ <- [ getLoc e ]], False)
 #endif
+getRecSels _ = (Nothing, False)
 
-collectConvRecSels' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectConvertedRecordSelectorsResult
-collectConvRecSels' ideState =
+collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordSelectorsResult
+collectRecSelResult ideState =
   handleMaybeM "Unable to TypeCheck"
     . liftIO
     . runAction "overloadedRecordDot.collectRecordSelectors" ideState