From 76d8b8886a45b3d6058becc173733f9a6f8ab3b9 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Thu, 1 Dec 2022 16:25:18 +0100 Subject: [PATCH 01/17] Initial working version --- .../Development/IDE/GHC/Compat/Outputable.hs | 17 +++++ ghcide/src/Development/IDE/GHC/Util.hs | 9 +++ .../src/Ide/Plugin/ExplicitFields.hs | 72 ++++++++++++++++--- .../test/Main.hs | 1 + .../test/testdata/Unused.expected.hs | 14 ++++ .../test/testdata/Unused.hs | 13 ++++ 6 files changed, 115 insertions(+), 11 deletions(-) create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 0dd10fc9a3..8bf3059b72 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -9,6 +9,7 @@ module Development.IDE.GHC.Compat.Outputable ( ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, + printWithUniques, mkPrintUnqualified, mkPrintUnqualifiedDefault, PrintUnqualified(..), @@ -104,6 +105,22 @@ printWithoutUniques = dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques #endif +printWithUniques :: Outputable a => a -> String +printWithUniques = +#if MIN_VERSION_ghc(9,2,0) + renderWithContext (defaultSDocContext + { + sdocStyle = defaultUserStyle + , sdocSuppressUniques = False + , sdocCanUseUnicode = True + }) . ppr +#else + go . ppr + where + go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) + dflags = unsafeGlobalDynFlags `gopt_unset` Opt_SuppressUniques `dopt_set` Opt_D_ppr_debug +#endif + printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String #if MIN_VERSION_ghc(9,2,0) printSDocQualifiedUnsafe unqual doc = diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index ca108ebc4d..28ad9b9240 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -27,6 +27,7 @@ module Development.IDE.GHC.Util( dontWriteHieFiles, disableWarningsAsErrors, printOutputable, + printOutputable', getExtensions ) where @@ -298,5 +299,13 @@ printOutputable = unescape . T.pack . printWithoutUniques {-# INLINE printOutputable #-} +printOutputable' :: Outputable a => a -> T.Text +printOutputable' = + -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. + -- Showing a String escapes non-ascii printable characters. We unescape it here. + -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. + unescape . T.pack . printWithUniques +{-# INLINE printOutputable' #-} + getExtensions :: ParsedModule -> [Extension] getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index e2bf77265d..caa8b890be 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -18,7 +18,7 @@ import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Data.Generics (GenericQ, everything, extQ, - mkQ) + mkQ, listify) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isJust, listToMaybe, maybeToList) @@ -26,7 +26,7 @@ import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), - realSrcSpanToRange) + realSrcSpanToRange, vcat) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -42,9 +42,9 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), RealSrcSpan, conPatDetails, hfbPun, hs_valds, mapConPatDetail, mapLoc, - pattern RealSrcSpan) + pattern RealSrcSpan, Name, HsRecField' (..), NamedThing (..), mkVarOcc, nameOccName, FieldOcc, SrcSpan, GenLocated (..), nameUnique, LIdP, nameSrcSpan) import Development.IDE.GHC.Util (getExtensions, - printOutputable) + printOutputable, printOutputable') import Development.IDE.Graph (RuleResult) import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), @@ -73,17 +73,24 @@ import Language.LSP.Types (CodeAction (..), normalizedFilePathToUri, type (|?) (InR)) import qualified Language.LSP.Types.Lens as L +import Development.IDE (hcat) +import Data.Foldable (find) +import Debug.Trace (trace) data Log = LogShake Shake.Log | LogCollectedRecords [RecordInfo] + | LogCollectedNames [LIdP (GhcPass 'Renamed)] | LogRenderedRecords [RenderedRecordInfo] instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs + LogCollectedNames names -> + let names' = map (\(L l e) -> pretty (show l) <+> pretty (printOutputable' e)) names + in "Collected names:" <+> vcat names' LogRenderedRecords recs -> "Rendered records:" <+> pretty recs descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -142,7 +149,9 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect let exts = getEnabledExtensions <$> tmr recs = concat $ maybeToList (getRecords <$> tmr) logWith recorder Debug (LogCollectedRecords recs) - let renderedRecs = traverse renderRecordInfo recs + let names = concat $ maybeToList (getNames <$> tmr) + logWith recorder Info (LogCollectedNames names) + let renderedRecs = traverse (renderRecordInfo names) recs recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) pure ([], CRR <$> recMap <*> exts) @@ -154,6 +163,9 @@ getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds +getNames :: TcModuleResult -> [LIdP (GhcPass 'Renamed)] +getNames (tmrRenamed -> (group,_,_,_)) = collectNames group + data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -199,9 +211,13 @@ instance Pretty RenderedRecordInfo where instance NFData RenderedRecordInfo -renderRecordInfo :: RecordInfo -> Maybe RenderedRecordInfo -renderRecordInfo (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat pat -renderRecordInfo (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr +renderRecordInfo :: [LIdP (GhcPass 'Renamed)] -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat +renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr + +-- mkVarOcc +-- getFieldName :: HsRecField' id arg -> Name +-- getFieldName = getName -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted @@ -225,9 +241,40 @@ preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns rec_flds' = no_puns <> puns' -showRecordPat :: Outputable (Pat (GhcPass c)) => Pat (GhcPass c) -> Maybe Text -showRecordPat = fmap printOutputable . mapConPatDetail (\case - RecCon flds -> Just $ RecCon (preprocessRecord flds) +preprocessRecord' :: [LIdP (GhcPass 'Renamed)] -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) +preprocessRecord' names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } + where + no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be + -- left as is, hence the split. + (no_puns, puns) = splitAt no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = let v = map (mapLoc (\fld -> fld { hfbPun = True })) puns in trace ("puns before: " <> show v) v + -- default to expanding if somehow `Nothing` ends up here + f :: Name -> Bool + f name = trace ("field: " <> show (printOutputable' name) <> " " <> show (nameSrcSpan name)) $ + isJust $ find (\n -> unLoc n == name && srcSpanToRealSrcSpan (getLoc n) /= srcSpanToRealSrcSpan (nameSrcSpan name)) names + puns'' = let v = filter (\x -> maybe True f (getFieldName (unLoc x))) puns' in trace ("puns after: " <> show v) v + + rec_flds' = no_puns <> puns'' + +srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan +srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss +srcSpanToRealSrcSpan _ = Nothing + +getFieldName :: HsRecField' (FieldOcc (GhcPass 'Renamed)) (LPat (GhcPass 'Renamed)) -> Maybe Name +getFieldName x = case unLoc (hsRecFieldArg x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing + +-- getFieldName :: GenLocated SrcSpan (HsRecField' (FieldOcc (GhcPass c)) arg) -> Name +-- getFieldName = _ + +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => [LIdP (GhcPass 'Renamed)] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat names = fmap printOutputable . mapConPatDetail (\case + RecCon flds -> Just $ RecCon (preprocessRecord' names flds) _ -> Nothing) showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text @@ -239,6 +286,9 @@ showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) +collectNames :: GenericQ [LIdP (GhcPass 'Renamed)] +collectNames = listify (const True) + getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = mkRecInfo e diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 2955c5bc4d..7262cdbe3a 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -21,6 +21,7 @@ plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" test :: TestTree test = testGroup "explicit-fields" [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 , mkTest "WithPun" "WithPun" 13 10 13 25 , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 13 10 13 37 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs new file mode 100644 index 0000000000..dca2fb00fd --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Unused where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , foobar :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar} = show foo ++ show bar diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs new file mode 100644 index 0000000000..3943043a58 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Unused where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , foobar :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = show foo ++ show bar From f553ec0e808ffc1cd18ca49927b1e3ca31de9031 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Thu, 1 Dec 2022 18:25:04 +0100 Subject: [PATCH 02/17] Cleanup, some compat work --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 8 ++ .../Development/IDE/GHC/Compat/Outputable.hs | 17 ----- ghcide/src/Development/IDE/GHC/Util.hs | 9 --- .../src/Ide/Plugin/ExplicitFields.hs | 73 ++++++++----------- 4 files changed, 40 insertions(+), 67 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 56579f6130..855c4893ca 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -209,6 +209,7 @@ module Development.IDE.GHC.Compat.Core ( noLocA, unLocA, LocatedAn, + LocatedN, #if MIN_VERSION_ghc(9,2,0) GHC.AnnListItem(..), GHC.NameAnn(..), @@ -1031,6 +1032,13 @@ type LocatedAn a = GHC.LocatedAn a type LocatedAn a = GHC.Located #endif +#if MIN_VERSION_ghc(9,2,0) +type LocatedN = GHC.LocatedN +#else +type LocatedN = GHC.Located +#endif + + #if MIN_VERSION_ghc(9,2,0) locA :: SrcSpanAnn' a -> SrcSpan locA = GHC.locA diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 8bf3059b72..0dd10fc9a3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -9,7 +9,6 @@ module Development.IDE.GHC.Compat.Outputable ( ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, - printWithUniques, mkPrintUnqualified, mkPrintUnqualifiedDefault, PrintUnqualified(..), @@ -105,22 +104,6 @@ printWithoutUniques = dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques #endif -printWithUniques :: Outputable a => a -> String -printWithUniques = -#if MIN_VERSION_ghc(9,2,0) - renderWithContext (defaultSDocContext - { - sdocStyle = defaultUserStyle - , sdocSuppressUniques = False - , sdocCanUseUnicode = True - }) . ppr -#else - go . ppr - where - go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) - dflags = unsafeGlobalDynFlags `gopt_unset` Opt_SuppressUniques `dopt_set` Opt_D_ppr_debug -#endif - printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String #if MIN_VERSION_ghc(9,2,0) printSDocQualifiedUnsafe unqual doc = diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 28ad9b9240..ca108ebc4d 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -27,7 +27,6 @@ module Development.IDE.GHC.Util( dontWriteHieFiles, disableWarningsAsErrors, printOutputable, - printOutputable', getExtensions ) where @@ -299,13 +298,5 @@ printOutputable = unescape . T.pack . printWithoutUniques {-# INLINE printOutputable #-} -printOutputable' :: Outputable a => a -> T.Text -printOutputable' = - -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. - -- Showing a String escapes non-ascii printable characters. We unescape it here. - -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. - unescape . T.pack . printWithUniques -{-# INLINE printOutputable' #-} - getExtensions :: ParsedModule -> [Extension] getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index caa8b890be..68b2ef156a 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -17,8 +17,9 @@ module Ide.Plugin.ExplicitFields import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (find) import Data.Generics (GenericQ, everything, extQ, - mkQ, listify) + listify, mkQ) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isJust, listToMaybe, maybeToList) @@ -26,7 +27,8 @@ import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), - realSrcSpanToRange, vcat) + hcat, hsep, realSpan, + realSrcSpanToRange) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -36,15 +38,21 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + FieldOcc, GenLocated (..), GhcPass, HsExpr (RecordCon, rcon_flds), - LHsExpr, Pass (..), Pat (..), - RealSrcSpan, conPatDetails, - hfbPun, hs_valds, + LHsExpr, LIdP, LocatedN, Name, + NamedThing (..), Pass (..), + Pat (..), RealSrcSpan, + SrcSpan, conPatDetails, + hfbPun, hfbRHS, hs_valds, mapConPatDetail, mapLoc, - pattern RealSrcSpan, Name, HsRecField' (..), NamedThing (..), mkVarOcc, nameOccName, FieldOcc, SrcSpan, GenLocated (..), nameUnique, LIdP, nameSrcSpan) + mkVarOcc, nameOccName, + nameSrcSpan, nameUnique, + pattern HsFieldBind, + pattern RealSrcSpan) import Development.IDE.GHC.Util (getExtensions, - printOutputable, printOutputable') + printOutputable) import Development.IDE.Graph (RuleResult) import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), @@ -73,15 +81,12 @@ import Language.LSP.Types (CodeAction (..), normalizedFilePathToUri, type (|?) (InR)) import qualified Language.LSP.Types.Lens as L -import Development.IDE (hcat) -import Data.Foldable (find) -import Debug.Trace (trace) data Log = LogShake Shake.Log | LogCollectedRecords [RecordInfo] - | LogCollectedNames [LIdP (GhcPass 'Renamed)] + | LogCollectedNames [LocatedN Name] | LogRenderedRecords [RenderedRecordInfo] instance Pretty Log where @@ -89,8 +94,8 @@ instance Pretty Log where LogShake shakeLog -> pretty shakeLog LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs LogCollectedNames names -> - let names' = map (\(L l e) -> pretty (show l) <+> pretty (printOutputable' e)) names - in "Collected names:" <+> vcat names' + let names' = map (\(L l e) -> (printOutputable l, printOutputable e)) names + in "Collected names:" <+> pretty names' LogRenderedRecords recs -> "Rendered records:" <+> pretty recs descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -150,7 +155,7 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect recs = concat $ maybeToList (getRecords <$> tmr) logWith recorder Debug (LogCollectedRecords recs) let names = concat $ maybeToList (getNames <$> tmr) - logWith recorder Info (LogCollectedNames names) + logWith recorder Debug (LogCollectedNames names) let renderedRecs = traverse (renderRecordInfo names) recs recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) @@ -163,7 +168,7 @@ getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds -getNames :: TcModuleResult -> [LIdP (GhcPass 'Renamed)] +getNames :: TcModuleResult -> [LocatedN Name] getNames (tmrRenamed -> (group,_,_,_)) = collectNames group data CollectRecords = CollectRecords @@ -211,14 +216,10 @@ instance Pretty RenderedRecordInfo where instance NFData RenderedRecordInfo -renderRecordInfo :: [LIdP (GhcPass 'Renamed)] -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo :: [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr --- mkVarOcc --- getFieldName :: HsRecField' id arg -> Name --- getFieldName = getName - -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted -- with the original record later. However, `Outputable` instance of @@ -241,7 +242,7 @@ preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns rec_flds' = no_puns <> puns' -preprocessRecord' :: [LIdP (GhcPass 'Renamed)] -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) +preprocessRecord' :: [LocatedN Name] -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) preprocessRecord' names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } where no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) @@ -251,28 +252,18 @@ preprocessRecord' names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds -- `hsRecPun` is set to `True` in order to pretty-print the fields as field -- puns (since there is similar mechanism in the `Outputable` instance as -- explained above). - puns' = let v = map (mapLoc (\fld -> fld { hfbPun = True })) puns in trace ("puns before: " <> show v) v + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns -- default to expanding if somehow `Nothing` ends up here - f :: Name -> Bool - f name = trace ("field: " <> show (printOutputable' name) <> " " <> show (nameSrcSpan name)) $ - isJust $ find (\n -> unLoc n == name && srcSpanToRealSrcSpan (getLoc n) /= srcSpanToRealSrcSpan (nameSrcSpan name)) names - puns'' = let v = filter (\x -> maybe True f (getFieldName (unLoc x))) puns' in trace ("puns after: " <> show v) v + f name = isJust $ find (\n -> unLoc n == name && realSpan (getLoc n) /= realSpan (nameSrcSpan name)) names + puns'' = filter (\x -> maybe True f (getFieldName (unLoc x))) puns' rec_flds' = no_puns <> puns'' -srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan -srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss -srcSpanToRealSrcSpan _ = Nothing - -getFieldName :: HsRecField' (FieldOcc (GhcPass 'Renamed)) (LPat (GhcPass 'Renamed)) -> Maybe Name -getFieldName x = case unLoc (hsRecFieldArg x) of - VarPat _ x' -> Just $ unLoc x' - _ -> Nothing - --- getFieldName :: GenLocated SrcSpan (HsRecField' (FieldOcc (GhcPass c)) arg) -> Name --- getFieldName = _ + getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => [LIdP (GhcPass 'Renamed)] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecord' names flds) _ -> Nothing) @@ -286,7 +277,7 @@ showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) -collectNames :: GenericQ [LIdP (GhcPass 'Renamed)] +collectNames :: GenericQ [LocatedN Name] collectNames = listify (const True) getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo @@ -295,7 +286,7 @@ getRecCons e@(unLoc -> RecordCon _ _ flds) where mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo mkRecInfo expr = listToMaybe - [ RecordInfoCon realSpan (unLoc expr) | RealSrcSpan realSpan _ <- [ getLoc expr ]] + [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] getRecCons _ = Nothing getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo @@ -304,7 +295,7 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) where mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo mkRecInfo pat = listToMaybe - [ RecordInfoPat realSpan (unLoc pat) | RealSrcSpan realSpan _ <- [ getLoc pat ]] + [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = Nothing collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult From 5eb449b10d037cf992bd28c1e60a1df23651d2ad Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Thu, 1 Dec 2022 18:53:41 +0100 Subject: [PATCH 03/17] Update mixed test to include an unused field --- plugins/hls-explicit-record-fields-plugin/test/Main.hs | 2 +- .../test/testdata/Mixed.expected.hs | 1 + .../hls-explicit-record-fields-plugin/test/testdata/Mixed.hs | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 7262cdbe3a..783902417a 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -24,7 +24,7 @@ test = testGroup "explicit-fields" , mkTest "Unused" "Unused" 12 10 12 20 , mkTest "WithPun" "WithPun" 13 10 13 25 , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 - , mkTest "Mixed" "Mixed" 13 10 13 37 + , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs index 93adb44a44..fa7f32ab25 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs @@ -8,6 +8,7 @@ data MyRec = MyRec { foo :: Int , bar :: Int , baz :: Char + , quux :: Double } convertMe :: MyRec -> String diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs index 810c78eca7..ccf56cd3ab 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs @@ -8,6 +8,7 @@ data MyRec = MyRec { foo :: Int , bar :: Int , baz :: Char + , quux :: Double } convertMe :: MyRec -> String From 6d3fe54906f7354cf31ec2897eb96463d5292b98 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 2 Dec 2022 11:12:43 +0100 Subject: [PATCH 04/17] Remove redundant imports, add a test case --- .../src/Ide/Plugin/ExplicitFields.hs | 17 ++++++----------- .../test/Main.hs | 1 + .../test/testdata/Unused.expected.hs | 2 +- .../test/testdata/Unused.hs | 2 +- 4 files changed, 9 insertions(+), 13 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 68b2ef156a..85d2399afc 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -27,8 +27,7 @@ import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), - hcat, hsep, realSpan, - realSrcSpanToRange) + realSpan, realSrcSpanToRange) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -38,18 +37,14 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - FieldOcc, GenLocated (..), - GhcPass, + GenLocated (..), GhcPass, HsExpr (RecordCon, rcon_flds), - LHsExpr, LIdP, LocatedN, Name, - NamedThing (..), Pass (..), - Pat (..), RealSrcSpan, - SrcSpan, conPatDetails, + LHsExpr, LocatedN, Name, + Pass (..), Pat (..), + RealSrcSpan, conPatDetails, hfbPun, hfbRHS, hs_valds, mapConPatDetail, mapLoc, - mkVarOcc, nameOccName, - nameSrcSpan, nameUnique, - pattern HsFieldBind, + nameSrcSpan, pattern RealSrcSpan) import Development.IDE.GHC.Util (getExtensions, printOutputable) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 783902417a..abbf3d8809 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -22,6 +22,7 @@ test :: TestTree test = testGroup "explicit-fields" [ 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 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs index dca2fb00fd..29abba1cfa 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.expected.hs @@ -7,7 +7,7 @@ module Unused where data MyRec = MyRec { foo :: Int , bar :: Int - , foobar :: Char + , baz :: Char } convertMe :: MyRec -> String diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs index 3943043a58..40b98e9403 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused.hs @@ -6,7 +6,7 @@ module Unused where data MyRec = MyRec { foo :: Int , bar :: Int - , foobar :: Char + , baz :: Char } convertMe :: MyRec -> String From 1facb9cd07bff83ff4b62258f918e8828908b8c0 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 6 Dec 2022 21:39:16 +0100 Subject: [PATCH 05/17] Reorganize name related functions --- .../src/Ide/Plugin/ExplicitFields.hs | 67 +++++++++++-------- 1 file changed, 40 insertions(+), 27 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 85d2399afc..74bc305e87 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -45,7 +45,7 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), hfbPun, hfbRHS, hs_valds, mapConPatDetail, mapLoc, nameSrcSpan, - pattern RealSrcSpan) + pattern RealSrcSpan, LHsRecField) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -163,6 +163,8 @@ getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds +-- | Collects all 'Name's of a given source file, to be used +-- in the variable usage analysis. getNames :: TcModuleResult -> [LocatedN Name] getNames (tmrRenamed -> (group,_,_,_)) = collectNames group @@ -215,6 +217,33 @@ renderRecordInfo :: [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr +-- | Checks if a 'Name' is referenced in a given list of names. The 'Eq' +-- instance of 'Name's makes use of their unique identifiers, hence any +-- to 'Name' referring to the same entity is considered equal. In order +-- to ensure that no false-positive is reported (in the case where the +-- 'name' itself is part of the given list), the inequality of source +-- locations is also checked. +referencedIn :: Name -> [LocatedN Name] -> Bool +referencedIn name names = isJust $ + find (\n -> unLoc n == name && realSpan (getLoc n) /= realSpan (nameSrcSpan name)) names + +-- Default to leaving the element in if somehow a name can't be extracted (i.e. +-- `getName` returns `Nothing`). +filterReferenced :: (a -> Maybe Name) -> [LocatedN Name] -> [a] -> [a] +filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + +preprocessRecordPat :: [LocatedN Name] -> + HsRecFields p (LPat (GhcPass 'Renamed)) -> HsRecFields p (LPat (GhcPass 'Renamed)) +preprocessRecordPat = preprocessRecord (getFieldName . unLoc) + where + getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing + +-- No need to check the name usage in the record construction case +preprocessRecordCon :: HsRecFields p arg -> HsRecFields p arg +preprocessRecordCon = preprocessRecord (const Nothing) [] + -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted -- with the original record later. However, `Outputable` instance of @@ -224,8 +253,10 @@ renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecor -- as we want to print the records in their fully expanded form. -- Here `rec_dotdot` is set to `Nothing` so that fields are printed without -- such post-processing. -preprocessRecord :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg -preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } +preprocessRecord :: + (LHsRecField p arg -> Maybe Name) -> [LocatedN Name] -> + HsRecFields p arg -> HsRecFields p arg +preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } where no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) -- Field binds of the explicit form (e.g. `{ a = a' }`) should be @@ -235,38 +266,20 @@ preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } -- puns (since there is similar mechanism in the `Outputable` instance as -- explained above). puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns - rec_flds' = no_puns <> puns' - -preprocessRecord' :: [LocatedN Name] -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) -> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed)) -preprocessRecord' names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } - where - no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) - -- Field binds of the explicit form (e.g. `{ a = a' }`) should be - -- left as is, hence the split. - (no_puns, puns) = splitAt no_pun_count (rec_flds flds) - -- `hsRecPun` is set to `True` in order to pretty-print the fields as field - -- puns (since there is similar mechanism in the `Outputable` instance as - -- explained above). - puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns - -- default to expanding if somehow `Nothing` ends up here - f name = isJust $ find (\n -> unLoc n == name && realSpan (getLoc n) /= realSpan (nameSrcSpan name)) names - puns'' = filter (\x -> maybe True f (getFieldName (unLoc x))) puns' - - rec_flds' = no_puns <> puns'' - - getFieldName x = case unLoc (hfbRHS x) of - VarPat _ x' -> Just $ unLoc x' - _ -> Nothing + -- Unused fields are filtered out so that they don't end up in the expanded + -- form. + punsUsed = filterReferenced getName names puns' + rec_flds' = no_puns <> punsUsed showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case - RecCon flds -> Just $ RecCon (preprocessRecord' names flds) + RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text showRecordCon expr@(RecordCon _ _ flds) = Just $ printOutputable $ - expr { rcon_flds = preprocessRecord flds } + expr { rcon_flds = preprocessRecordCon flds } showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] From ee7b03eca8033a5704d330ad9b78922d4f606e54 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 6 Dec 2022 21:43:33 +0100 Subject: [PATCH 06/17] Build name map instead of walking through list --- .../hls-explicit-record-fields-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitFields.hs | 80 ++++++++++++------- 2 files changed, 50 insertions(+), 31 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal index 92a4e1cf5a..7ed2cfcd04 100644 --- a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal +++ b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal @@ -38,6 +38,7 @@ library , transformers , ghc-boot-th , unordered-containers + , containers hs-source-dirs: src default-language: Haskell2010 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 74bc305e87..78a3ef84d6 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor @@ -19,9 +21,11 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Data.Foldable (find) import Data.Generics (GenericQ, everything, extQ, - listify, mkQ) + mkQ) import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (isJust, listToMaybe, +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust, listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, @@ -39,13 +43,15 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), GenLocated (..), GhcPass, HsExpr (RecordCon, rcon_flds), - LHsExpr, LocatedN, Name, - Pass (..), Pat (..), - RealSrcSpan, conPatDetails, + LHsExpr, LHsRecField, + LocatedN, Name, Pass (..), + Pat (..), RealSrcSpan, + conPatDetails, getUnique, hfbPun, hfbRHS, hs_valds, mapConPatDetail, mapLoc, - nameSrcSpan, - pattern RealSrcSpan, LHsRecField) + nameSrcSpan, nameUnique, + pattern RealSrcSpan) +import Development.IDE.GHC.Compat.Util (Unique, nonDetCmpUnique) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -149,8 +155,9 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect let exts = getEnabledExtensions <$> tmr recs = concat $ maybeToList (getRecords <$> tmr) logWith recorder Debug (LogCollectedRecords recs) - let names = concat $ maybeToList (getNames <$> tmr) - logWith recorder Debug (LogCollectedNames names) + -- TODO(ozkutuk): refactor fromJust + let names = fromJust $ getNames <$> tmr + -- logWith recorder Debug (LogCollectedNames names) let renderedRecs = traverse (renderRecordInfo names) recs recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) @@ -165,9 +172,18 @@ getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. -getNames :: TcModuleResult -> [LocatedN Name] +getNames :: TcModuleResult -> Map UniqueKey [LocatedN Name] getNames (tmrRenamed -> (group,_,_,_)) = collectNames group +newtype UniqueKey = UniqueKey Unique + deriving newtype Eq + +getUniqueKey :: Name -> UniqueKey +getUniqueKey = UniqueKey . nameUnique + +instance Ord UniqueKey where + compare (UniqueKey u1) (UniqueKey u2) = getUnique u1 `nonDetCmpUnique` getUnique u2 + data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -213,7 +229,7 @@ instance Pretty RenderedRecordInfo where instance NFData RenderedRecordInfo -renderRecordInfo :: [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo :: Map UniqueKey [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr @@ -223,16 +239,18 @@ renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecor -- to ensure that no false-positive is reported (in the case where the -- 'name' itself is part of the given list), the inequality of source -- locations is also checked. -referencedIn :: Name -> [LocatedN Name] -> Bool -referencedIn name names = isJust $ - find (\n -> unLoc n == name && realSpan (getLoc n) /= realSpan (nameSrcSpan name)) names +referencedIn :: Name -> Map UniqueKey [LocatedN Name] -> Bool +referencedIn name names = maybe True hasNameRef $ Map.lookup (getUniqueKey name) names + where + hasNameRef :: [LocatedN Name] -> Bool + hasNameRef = isJust . find (\n -> realSpan (getLoc n) /= realSpan (nameSrcSpan name)) -- Default to leaving the element in if somehow a name can't be extracted (i.e. -- `getName` returns `Nothing`). -filterReferenced :: (a -> Maybe Name) -> [LocatedN Name] -> [a] -> [a] +filterReferenced :: (a -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) -preprocessRecordPat :: [LocatedN Name] -> +preprocessRecordPat :: Map UniqueKey [LocatedN Name] -> HsRecFields p (LPat (GhcPass 'Renamed)) -> HsRecFields p (LPat (GhcPass 'Renamed)) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) where @@ -242,7 +260,7 @@ preprocessRecordPat = preprocessRecord (getFieldName . unLoc) -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields p arg -> HsRecFields p arg -preprocessRecordCon = preprocessRecord (const Nothing) [] +preprocessRecordCon = preprocessRecord (const Nothing) Map.empty -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted @@ -254,7 +272,7 @@ preprocessRecordCon = preprocessRecord (const Nothing) [] -- Here `rec_dotdot` is set to `Nothing` so that fields are printed without -- such post-processing. preprocessRecord :: - (LHsRecField p arg -> Maybe Name) -> [LocatedN Name] -> + (LHsRecField p arg -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> HsRecFields p arg -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } where @@ -271,7 +289,7 @@ preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = r punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => Map UniqueKey [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) @@ -285,8 +303,8 @@ showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) -collectNames :: GenericQ [LocatedN Name] -collectNames = listify (const True) +collectNames :: GenericQ (Map UniqueKey [LocatedN Name]) +collectNames = everything (Map.unionWith (<>)) (Map.empty `mkQ` (\x -> Map.singleton (getUniqueKey (unLoc x)) [x])) getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo getRecCons e@(unLoc -> RecordCon _ _ flds) From b77be050c9c5ffb91808973e549f78715577aad3 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Wed, 7 Dec 2022 18:51:12 +0100 Subject: [PATCH 07/17] Refactor fromJust --- .../hls-explicit-record-fields-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitFields.hs | 37 +++++++++---------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal index 7ed2cfcd04..5a0eae1564 100644 --- a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal +++ b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal @@ -39,6 +39,7 @@ library , ghc-boot-th , unordered-containers , containers + , extra hs-source-dirs: src default-language: Haskell2010 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 78a3ef84d6..1456939744 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -17,6 +17,7 @@ module Ide.Plugin.ExplicitFields ) where import Control.Lens ((^.)) +import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Data.Foldable (find) @@ -25,7 +26,7 @@ import Data.Generics (GenericQ, everything, extQ, import qualified Data.HashMap.Strict as HashMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust, listToMaybe, +import Data.Maybe (isJust, listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, @@ -41,7 +42,7 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GenLocated (..), GhcPass, + GhcPass, HsExpr (RecordCon, rcon_flds), LHsExpr, LHsRecField, LocatedN, Name, Pass (..), @@ -87,16 +88,12 @@ import qualified Language.LSP.Types.Lens as L data Log = LogShake Shake.Log | LogCollectedRecords [RecordInfo] - | LogCollectedNames [LocatedN Name] | LogRenderedRecords [RenderedRecordInfo] instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs - LogCollectedNames names -> - let names' = map (\(L l e) -> (printOutputable l, printOutputable e)) names - in "Collected names:" <+> pretty names' LogRenderedRecords recs -> "Rendered records:" <+> pretty recs descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -150,22 +147,24 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes title = "Expand record wildcard" collectRecordsRule :: Recorder (WithPriority Log) -> Rules () -collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> do - tmr <- use TypeCheck nfp - let exts = getEnabledExtensions <$> tmr - recs = concat $ maybeToList (getRecords <$> tmr) - logWith recorder Debug (LogCollectedRecords recs) - -- TODO(ozkutuk): refactor fromJust - let names = fromJust $ getNames <$> tmr - -- logWith recorder Debug (LogCollectedNames names) - let renderedRecs = traverse (renderRecordInfo names) recs - recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs - logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) - pure ([], CRR <$> recMap <*> exts) +collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> + justOrFail "Unable to TypeCheck" (use TypeCheck nfp) $ \tmr -> do + let exts = getEnabledExtensions tmr + recs = getRecords tmr + logWith recorder Debug (LogCollectedRecords recs) + let names = getNames tmr + renderedRecs = traverse (renderRecordInfo names) recs + recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs + logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) + pure ([], CRR <$> recMap <*> Just exts) + where getEnabledExtensions :: TcModuleResult -> [GhcExtension] getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed + justOrFail :: MonadFail m => String -> m (Maybe a) -> (a -> m b) -> m b + justOrFail = flip . maybeM . fail + getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds @@ -176,7 +175,7 @@ getNames :: TcModuleResult -> Map UniqueKey [LocatedN Name] getNames (tmrRenamed -> (group,_,_,_)) = collectNames group newtype UniqueKey = UniqueKey Unique - deriving newtype Eq + deriving newtype Eq getUniqueKey :: Name -> UniqueKey getUniqueKey = UniqueKey . nameUnique From 2963e8325ab49de1959bbb817accf39b27054a08 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 9 Dec 2022 16:07:10 +0100 Subject: [PATCH 08/17] Make it compatible with GHC 9.2 --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 7 ++++ .../src/Ide/Plugin/ExplicitFields.hs | 35 +++++++++++-------- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 855c4893ca..ecb11664a4 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -209,6 +209,7 @@ module Development.IDE.GHC.Compat.Core ( noLocA, unLocA, LocatedAn, + LocatedA, LocatedN, #if MIN_VERSION_ghc(9,2,0) GHC.AnnListItem(..), @@ -1032,6 +1033,12 @@ type LocatedAn a = GHC.LocatedAn a type LocatedAn a = GHC.Located #endif +#if MIN_VERSION_ghc(9,2,0) +type LocatedA = GHC.LocatedA +#else +type LocatedA = GHC.Located +#endif + #if MIN_VERSION_ghc(9,2,0) type LocatedN = GHC.LocatedN #else diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 1456939744..26ad2dd92d 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -42,15 +42,16 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, + FieldOcc, GhcPass, HsExpr (RecordCon, rcon_flds), - LHsExpr, LHsRecField, - LocatedN, Name, Pass (..), - Pat (..), RealSrcSpan, - conPatDetails, getUnique, - hfbPun, hfbRHS, hs_valds, - mapConPatDetail, mapLoc, - nameSrcSpan, nameUnique, + HsRecField', LHsExpr, + LocatedA, LocatedN, Name, + Pass (..), Pat (..), + RealSrcSpan, conPatDetails, + getUnique, hfbPun, hfbRHS, + hs_valds, mapConPatDetail, + mapLoc, nameSrcSpan, + nameUnique, pattern RealSrcSpan) import Development.IDE.GHC.Compat.Util (Unique, nonDetCmpUnique) import Development.IDE.GHC.Util (getExtensions, @@ -249,8 +250,11 @@ referencedIn name names = maybe True hasNameRef $ Map.lookup (getUniqueKey name) filterReferenced :: (a -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) -preprocessRecordPat :: Map UniqueKey [LocatedN Name] -> - HsRecFields p (LPat (GhcPass 'Renamed)) -> HsRecFields p (LPat (GhcPass 'Renamed)) +preprocessRecordPat + :: p ~ GhcPass 'Renamed + => Map UniqueKey [LocatedN Name] + -> HsRecFields p (LPat p) + -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) where getFieldName x = case unLoc (hfbRHS x) of @@ -258,7 +262,7 @@ preprocessRecordPat = preprocessRecord (getFieldName . unLoc) _ -> Nothing -- No need to check the name usage in the record construction case -preprocessRecordCon :: HsRecFields p arg -> HsRecFields p arg +preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg preprocessRecordCon = preprocessRecord (const Nothing) Map.empty -- We make use of the `Outputable` instances on AST types to pretty-print @@ -270,9 +274,12 @@ preprocessRecordCon = preprocessRecord (const Nothing) Map.empty -- as we want to print the records in their fully expanded form. -- Here `rec_dotdot` is set to `Nothing` so that fields are printed without -- such post-processing. -preprocessRecord :: - (LHsRecField p arg -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> - HsRecFields p arg -> HsRecFields p arg +preprocessRecord + :: p ~ GhcPass c + => (LocatedA (HsRecField' (FieldOcc p) arg) -> Maybe Name) + -> Map UniqueKey [LocatedN Name] + -> HsRecFields p arg + -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } where no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) From 86de83dffdc45f34af198ea802c35b7b7b8f1d4b Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 9 Dec 2022 16:24:50 +0100 Subject: [PATCH 09/17] Fix import conflicts --- .../hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs | 3 ++- .../src/Development/IDE/Plugin/CodeAction.hs | 7 +------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index e7297e1db8..7b22e9f812 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} module Development.IDE.GHC.Dump(showAstDataHtml) where import Data.Data hiding (Fixity) -import Development.IDE.GHC.Compat hiding (NameAnn) +import Development.IDE.GHC.Compat hiding (LocatedA, + NameAnn) import Development.IDE.GHC.Compat.ExactPrint import GHC.Hs.Dump #if MIN_VERSION_ghc(9,2,1) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 2b98b95a77..9052555388 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -102,8 +102,7 @@ import GHC (AddEpAnn (Ad DeltaPos (..), EpAnn (..), EpaLocation (..), - LEpaComment, - LocatedA) + LEpaComment) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -1535,11 +1534,7 @@ findPositionNoImports ps fileContents = -- | find line number right after module ... where findPositionAfterModuleName :: Annotated ParsedSource -#if MIN_VERSION_ghc(9,2,0) -> LocatedA ModuleName -#else - -> Located ModuleName -#endif -> Maybe Int findPositionAfterModuleName ps hsmodName' = do -- Note that 'where' keyword and comments are not part of the AST. They belongs to From 2b34834bd372af02433d766454120f6cb3d72f54 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 9 Dec 2022 16:42:07 +0100 Subject: [PATCH 10/17] Make it compatible with GHC 9.4 --- .../src/Ide/Plugin/ExplicitFields.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 26ad2dd92d..45fdbc3249 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -42,16 +42,15 @@ import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - FieldOcc, GhcPass, + GhcPass, HsExpr (RecordCon, rcon_flds), - HsRecField', LHsExpr, - LocatedA, LocatedN, Name, - Pass (..), Pat (..), - RealSrcSpan, conPatDetails, - getUnique, hfbPun, hfbRHS, - hs_valds, mapConPatDetail, - mapLoc, nameSrcSpan, - nameUnique, + HsRecField, LHsExpr, LocatedA, + LocatedN, Name, Pass (..), + Pat (..), RealSrcSpan, + conPatDetails, getUnique, + hfbPun, hfbRHS, hs_valds, + mapConPatDetail, mapLoc, + nameSrcSpan, nameUnique, pattern RealSrcSpan) import Development.IDE.GHC.Compat.Util (Unique, nonDetCmpUnique) import Development.IDE.GHC.Util (getExtensions, @@ -276,7 +275,7 @@ preprocessRecordCon = preprocessRecord (const Nothing) Map.empty -- such post-processing. preprocessRecord :: p ~ GhcPass c - => (LocatedA (HsRecField' (FieldOcc p) arg) -> Maybe Name) + => (LocatedA (HsRecField p arg) -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> HsRecFields p arg -> HsRecFields p arg From 2ee6874b10d4e15f2fd3a4a5002ae8218e33f8c4 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 9 Dec 2022 17:10:01 +0100 Subject: [PATCH 11/17] Add missing test files --- .../test/testdata/Unused2.expected.hs | 14 ++++++++++++++ .../test/testdata/Unused2.hs | 13 +++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs new file mode 100644 index 0000000000..5befab1ce8 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Unused2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar} = let baz = "baz" in show foo ++ show bar ++ baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs new file mode 100644 index 0000000000..e66f880072 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Unused2.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Unused2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = let baz = "baz" in show foo ++ show bar ++ baz From 6de5529c3ea3876a7275cae43c64b2a403036e9f Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Mon, 12 Dec 2022 22:14:56 +0100 Subject: [PATCH 12/17] Improve documentation, use UniqFM --- .../src/Ide/Plugin/ExplicitFields.hs | 97 +++++++++---------- 1 file changed, 47 insertions(+), 50 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 45fdbc3249..b464685632 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor @@ -20,19 +19,16 @@ import Control.Lens ((^.)) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) -import Data.Foldable (find) import Data.Generics (GenericQ, everything, extQ, mkQ) import qualified Data.HashMap.Strict as HashMap -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Data.Maybe (isJust, listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), - realSpan, realSrcSpanToRange) + realSrcSpanToRange) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -46,13 +42,12 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), HsExpr (RecordCon, rcon_flds), HsRecField, LHsExpr, LocatedA, LocatedN, Name, Pass (..), - Pat (..), RealSrcSpan, - conPatDetails, getUnique, + Pat (..), RealSrcSpan, UniqFM, + conPatDetails, emptyUFM, hfbPun, hfbRHS, hs_valds, - mapConPatDetail, mapLoc, - nameSrcSpan, nameUnique, - pattern RealSrcSpan) -import Development.IDE.GHC.Compat.Util (Unique, nonDetCmpUnique) + lookupUFM, mapConPatDetail, + mapLoc, pattern RealSrcSpan, + plusUFM_C, unitUFM) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -171,18 +166,9 @@ getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. -getNames :: TcModuleResult -> Map UniqueKey [LocatedN Name] +getNames :: TcModuleResult -> UniqFM Name [LocatedN Name] getNames (tmrRenamed -> (group,_,_,_)) = collectNames group -newtype UniqueKey = UniqueKey Unique - deriving newtype Eq - -getUniqueKey :: Name -> UniqueKey -getUniqueKey = UniqueKey . nameUnique - -instance Ord UniqueKey where - compare (UniqueKey u1) (UniqueKey u2) = getUnique u1 `nonDetCmpUnique` getUnique u2 - data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -228,30 +214,29 @@ instance Pretty RenderedRecordInfo where instance NFData RenderedRecordInfo -renderRecordInfo :: Map UniqueKey [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo :: UniqFM Name [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr --- | Checks if a 'Name' is referenced in a given list of names. The 'Eq' --- instance of 'Name's makes use of their unique identifiers, hence any --- to 'Name' referring to the same entity is considered equal. In order --- to ensure that no false-positive is reported (in the case where the --- 'name' itself is part of the given list), the inequality of source --- locations is also checked. -referencedIn :: Name -> Map UniqueKey [LocatedN Name] -> Bool -referencedIn name names = maybe True hasNameRef $ Map.lookup (getUniqueKey name) names +-- | Checks if a 'Name' is referenced in the given map of names. The +-- 'hasNonBindingOcc' check is necessary in order to make sure that only the +-- references at the use-sites are considered (i.e. the binding occurence +-- is excluded). For more information regarding the structure of the map, +-- refer to the documentation of 'collectNames'. +referencedIn :: Name -> UniqFM Name [LocatedN Name] -> Bool +referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name where - hasNameRef :: [LocatedN Name] -> Bool - hasNameRef = isJust . find (\n -> realSpan (getLoc n) /= realSpan (nameSrcSpan name)) + hasNonBindingOcc :: [LocatedN Name] -> Bool + hasNonBindingOcc = (> 1) . length -- Default to leaving the element in if somehow a name can't be extracted (i.e. -- `getName` returns `Nothing`). -filterReferenced :: (a -> Maybe Name) -> Map UniqueKey [LocatedN Name] -> [a] -> [a] +filterReferenced :: (a -> Maybe Name) -> UniqFM Name [LocatedN Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) preprocessRecordPat :: p ~ GhcPass 'Renamed - => Map UniqueKey [LocatedN Name] + => UniqFM Name [LocatedN Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) @@ -262,7 +247,7 @@ preprocessRecordPat = preprocessRecord (getFieldName . unLoc) -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg -preprocessRecordCon = preprocessRecord (const Nothing) Map.empty +preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted @@ -276,7 +261,7 @@ preprocessRecordCon = preprocessRecord (const Nothing) Map.empty preprocessRecord :: p ~ GhcPass c => (LocatedA (HsRecField p arg) -> Maybe Name) - -> Map UniqueKey [LocatedN Name] + -> UniqFM Name [LocatedN Name] -> HsRecFields p arg -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } @@ -294,7 +279,7 @@ preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = r punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => Map UniqueKey [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) @@ -308,8 +293,20 @@ showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) -collectNames :: GenericQ (Map UniqueKey [LocatedN Name]) -collectNames = everything (Map.unionWith (<>)) (Map.empty `mkQ` (\x -> Map.singleton (getUniqueKey (unLoc x)) [x])) +-- | Collect 'Name's into a map, indexed by the names' unique identifiers. +-- The 'Eq' instance of 'Name's makes use of their unique identifiers, hence +-- any 'Name' referring to the same entity is considered equal. In effect, +-- each individual list of names contains the binding occurence, along with +-- all the occurences at the use-sites (if there are any). +-- +-- @UniqFM Name [LocatedN Name]@ is morally the same as @Map Unique [LocatedN +-- Name]@. Using 'UniqFM' gains us a bit of performance (in theory) since it +-- internally uses 'IntMap', and saves us rolling our own newtype wrapper over +-- 'Unique' (since 'Unique' doesn't have an 'Ord' instance, it can't be used +-- as 'Map' key as is). More information regarding 'UniqFM' can be found in +-- the GHC source. +collectNames :: GenericQ (UniqFM Name [LocatedN Name]) +collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM (unLoc x) [x])) getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo getRecCons e@(unLoc -> RecordCon _ _ flds) From 04a1ed796639368befa3cccf1a20771d65b3809d Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Mon, 12 Dec 2022 22:40:47 +0100 Subject: [PATCH 13/17] Handle maybe without 'fail'ing --- .../hls-explicit-record-fields-plugin.cabal | 1 - .../src/Ide/Plugin/ExplicitFields.hs | 24 +++++++++---------- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal index 5a0eae1564..7ed2cfcd04 100644 --- a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal +++ b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal @@ -39,7 +39,6 @@ library , ghc-boot-th , unordered-containers , containers - , extra hs-source-dirs: src default-language: Haskell2010 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index b464685632..1081c53536 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -16,7 +16,6 @@ module Ide.Plugin.ExplicitFields ) where import Control.Lens ((^.)) -import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Data.Generics (GenericQ, everything, extQ, @@ -143,23 +142,22 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes collectRecordsRule :: Recorder (WithPriority Log) -> Rules () collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> - justOrFail "Unable to TypeCheck" (use TypeCheck nfp) $ \tmr -> do - let exts = getEnabledExtensions tmr - recs = getRecords tmr - logWith recorder Debug (LogCollectedRecords recs) - let names = getNames tmr - renderedRecs = traverse (renderRecordInfo names) recs - recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs - logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) - pure ([], CRR <$> recMap <*> Just exts) + use TypeCheck nfp >>= \case + Nothing -> pure ([], Nothing) + Just tmr -> do + let exts = getEnabledExtensions tmr + recs = getRecords tmr + logWith recorder Debug (LogCollectedRecords recs) + let names = getNames tmr + renderedRecs = traverse (renderRecordInfo names) recs + recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs + logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) + pure ([], CRR <$> recMap <*> Just exts) where getEnabledExtensions :: TcModuleResult -> [GhcExtension] getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed - justOrFail :: MonadFail m => String -> m (Maybe a) -> (a -> m b) -> m b - justOrFail = flip . maybeM . fail - getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds From 324e88ffd37a9d52cd51eb31fa4dd7bb0baba92e Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Mon, 12 Dec 2022 23:04:01 +0100 Subject: [PATCH 14/17] Add UniqFM compat --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index ecb11664a4..25e0a1acc0 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -479,6 +479,7 @@ module Development.IDE.GHC.Compat.Core ( #else Extension(..) #endif + UniqFM ) where import qualified GHC @@ -513,7 +514,8 @@ import GHC.Core.DataCon hiding (dataConExTyCoVars) import qualified GHC.Core.DataCon as DataCon import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM +import GHC.Types.Unique.FM hiding (UniqFM) +import qualified GHC.Types.Unique.FM as UniqFM #if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config.Tidy as GHC import qualified GHC.Data.Strict as Strict @@ -736,7 +738,8 @@ import Type import TysPrim import TysWiredIn import Unify -import UniqFM +import UniqFM hiding (UniqFM) +import qualified UniqFM import UniqSupply import Var (Var (varName), setTyVarUnique, setVarUnique, varType) @@ -1173,3 +1176,9 @@ pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLo pattern NamedFieldPuns :: Extension pattern NamedFieldPuns = RecordPuns #endif + +#if MIN_VERSION_ghc(9,0,0) +type UniqFM = UniqFM.UniqFM +#else +type UniqFM k = UniqFM.UniqFM +#endif From 6d6a599afb4c41737a7026747761127f33e2244f Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Wed, 14 Dec 2022 00:12:21 +0100 Subject: [PATCH 15/17] Fix import list --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 25e0a1acc0..72c8cc501b 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -477,9 +477,9 @@ module Development.IDE.GHC.Compat.Core ( #if !MIN_VERSION_ghc_boot_th(9,4,1) Extension(.., NamedFieldPuns), #else - Extension(..) + Extension(..), #endif - UniqFM + UniqFM, ) where import qualified GHC From 62c40365fde20d2d0cce8aada93cca227f10dc8b Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Mon, 19 Dec 2022 14:56:52 +0100 Subject: [PATCH 16/17] Make name collection its own rule --- .../src/Ide/Plugin/ExplicitFields.hs | 67 ++++++++++++++----- 1 file changed, 50 insertions(+), 17 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 1081c53536..7248af47c2 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -18,6 +18,7 @@ module Ide.Plugin.ExplicitFields import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) +import Data.Functor ((<&>)) import Data.Generics (GenericQ, everything, extQ, mkQ) import qualified Data.HashMap.Strict as HashMap @@ -46,7 +47,8 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), hfbPun, hfbRHS, hs_valds, lookupUFM, mapConPatDetail, mapLoc, pattern RealSrcSpan, - plusUFM_C, unitUFM) + plusUFM_C, ufmToIntMap, + unitUFM) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -93,7 +95,7 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider - , pluginRules = collectRecordsRule recorder + , pluginRules = collectRecordsRule recorder *> collectNamesRule } codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction @@ -148,11 +150,13 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect let exts = getEnabledExtensions tmr recs = getRecords tmr logWith recorder Debug (LogCollectedRecords recs) - let names = getNames tmr - renderedRecs = traverse (renderRecordInfo names) recs - recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs - logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) - pure ([], CRR <$> recMap <*> Just exts) + use CollectNames nfp >>= \case + Nothing -> pure ([], Nothing) + Just (CNR names) -> do + let renderedRecs = traverse (renderRecordInfo names) recs + recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs + logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) + pure ([], CRR <$> recMap <*> Just exts) where getEnabledExtensions :: TcModuleResult -> [GhcExtension] @@ -162,10 +166,16 @@ getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds +collectNamesRule :: Rules () +collectNamesRule = define mempty $ \CollectNames nfp -> + use TypeCheck nfp <&> \case + Nothing -> ([], Nothing) + Just tmr -> ([], Just (CNR (getNames tmr))) + -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. -getNames :: TcModuleResult -> UniqFM Name [LocatedN Name] -getNames (tmrRenamed -> (group,_,_,_)) = collectNames group +getNames :: TcModuleResult -> NameMap +getNames (tmrRenamed -> (group,_,_,_)) = NameMap (collectNames group) data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -186,6 +196,22 @@ instance Show CollectRecordsResult where type instance RuleResult CollectRecords = CollectRecordsResult +data CollectNames = CollectNames + deriving (Eq, Show, Generic) + +instance Hashable CollectNames +instance NFData CollectNames + +data CollectNamesResult = CNR NameMap + deriving (Generic) + +instance NFData CollectNamesResult + +instance Show CollectNamesResult where + show _ = "" + +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 } @@ -193,6 +219,13 @@ 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`. +newtype NameMap = NameMap (UniqFM Name [LocatedN Name]) + +instance NFData NameMap where + rnf (NameMap (ufmToIntMap -> m)) = rnf m + data RecordInfo = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) @@ -212,7 +245,7 @@ instance Pretty RenderedRecordInfo where instance NFData RenderedRecordInfo -renderRecordInfo :: UniqFM Name [LocatedN Name] -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr @@ -221,20 +254,20 @@ renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecor -- references at the use-sites are considered (i.e. the binding occurence -- is excluded). For more information regarding the structure of the map, -- refer to the documentation of 'collectNames'. -referencedIn :: Name -> UniqFM Name [LocatedN Name] -> Bool -referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name +referencedIn :: Name -> NameMap -> Bool +referencedIn name (NameMap names) = maybe True hasNonBindingOcc $ lookupUFM names name where hasNonBindingOcc :: [LocatedN Name] -> Bool hasNonBindingOcc = (> 1) . length -- Default to leaving the element in if somehow a name can't be extracted (i.e. -- `getName` returns `Nothing`). -filterReferenced :: (a -> Maybe Name) -> UniqFM Name [LocatedN Name] -> [a] -> [a] +filterReferenced :: (a -> Maybe Name) -> NameMap -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) preprocessRecordPat :: p ~ GhcPass 'Renamed - => UniqFM Name [LocatedN Name] + => NameMap -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) @@ -245,7 +278,7 @@ preprocessRecordPat = preprocessRecord (getFieldName . unLoc) -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg -preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM +preprocessRecordCon = preprocessRecord (const Nothing) (NameMap emptyUFM) -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted @@ -259,7 +292,7 @@ preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM preprocessRecord :: p ~ GhcPass c => (LocatedA (HsRecField p arg) -> Maybe Name) - -> UniqFM Name [LocatedN Name] + -> NameMap -> HsRecFields p arg -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } @@ -277,7 +310,7 @@ preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = r punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [LocatedN Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) From b1591263f37d6cdd371792b1a03f513d062c6c0e Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Mon, 19 Dec 2022 15:32:46 +0100 Subject: [PATCH 17/17] Remove LocatedN stuff, reorganize some docs --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 8 ------- .../src/Ide/Plugin/ExplicitFields.hs | 23 ++++++++++++------- 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 37036b944a..5ff0867782 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -217,7 +217,6 @@ module Development.IDE.GHC.Compat.Core ( unLocA, LocatedAn, LocatedA, - LocatedN, #if MIN_VERSION_ghc(9,2,0) GHC.AnnListItem(..), GHC.NameAnn(..), @@ -1049,13 +1048,6 @@ type LocatedA = GHC.LocatedA type LocatedA = GHC.Located #endif -#if MIN_VERSION_ghc(9,2,0) -type LocatedN = GHC.LocatedN -#else -type LocatedN = GHC.Located -#endif - - #if MIN_VERSION_ghc(9,2,0) locA :: SrcSpanAnn' a -> SrcSpan locA = GHC.locA diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 7248af47c2..e7e6c81683 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -41,8 +41,8 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), GhcPass, HsExpr (RecordCon, rcon_flds), HsRecField, LHsExpr, LocatedA, - LocatedN, Name, Pass (..), - Pat (..), RealSrcSpan, UniqFM, + Name, Pass (..), Pat (..), + RealSrcSpan, UniqFM, conPatDetails, emptyUFM, hfbPun, hfbRHS, hs_valds, lookupUFM, mapConPatDetail, @@ -221,7 +221,7 @@ instance NFData GhcExtension where -- As with `GhcExtension`, this newtype exists mostly to attach -- an `NFData` instance to `UniqFM`. -newtype NameMap = NameMap (UniqFM Name [LocatedN Name]) +newtype NameMap = NameMap (UniqFM Name [Name]) instance NFData NameMap where rnf (NameMap (ufmToIntMap -> m)) = rnf m @@ -257,7 +257,7 @@ renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecor referencedIn :: Name -> NameMap -> Bool referencedIn name (NameMap names) = maybe True hasNonBindingOcc $ lookupUFM names name where - hasNonBindingOcc :: [LocatedN Name] -> Bool + hasNonBindingOcc :: [Name] -> Bool hasNonBindingOcc = (> 1) . length -- Default to leaving the element in if somehow a name can't be extracted (i.e. @@ -280,6 +280,13 @@ preprocessRecordPat = preprocessRecord (getFieldName . unLoc) preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg preprocessRecordCon = preprocessRecord (const Nothing) (NameMap emptyUFM) +-- This function does two things: +-- 1) Tweak the AST type so that the pretty-printed record is in the +-- expanded form +-- 2) Determine the unused record fields so that they are filtered out +-- of the final output +-- +-- Regarding first point: -- We make use of the `Outputable` instances on AST types to pretty-print -- the renamed and expanded records back into source form, to be substituted -- with the original record later. However, `Outputable` instance of @@ -330,14 +337,14 @@ collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `e -- each individual list of names contains the binding occurence, along with -- all the occurences at the use-sites (if there are any). -- --- @UniqFM Name [LocatedN Name]@ is morally the same as @Map Unique [LocatedN --- Name]@. Using 'UniqFM' gains us a bit of performance (in theory) since it +-- @UniqFM Name [Name]@ is morally the same as @Map Unique [Name]@. +-- Using 'UniqFM' gains us a bit of performance (in theory) since it -- internally uses 'IntMap', and saves us rolling our own newtype wrapper over -- 'Unique' (since 'Unique' doesn't have an 'Ord' instance, it can't be used -- as 'Map' key as is). More information regarding 'UniqFM' can be found in -- the GHC source. -collectNames :: GenericQ (UniqFM Name [LocatedN Name]) -collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM (unLoc x) [x])) +collectNames :: GenericQ (UniqFM Name [Name]) +collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo getRecCons e@(unLoc -> RecordCon _ _ flds)