From ccf3487596705ceed937667d7d24424a363b6c4d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 8 Aug 2023 16:59:05 +0300 Subject: [PATCH 01/10] Fix #3574 and support resolve in explicit records --- ghcide/src/Development/IDE/GHC/Orphans.hs | 5 +- .../hls-explicit-record-fields-plugin.cabal | 9 + .../src/Ide/Plugin/ExplicitFields.hs | 253 +++++++++--------- 3 files changed, 133 insertions(+), 134 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 581ae70567..3000133da2 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -39,8 +39,8 @@ import Data.Hashable import Data.String (IsString (fromString)) import Data.Text (unpack) #if MIN_VERSION_ghc(9,0,0) +import GHC (ModuleGraph) import GHC.ByteCode.Types -import GHC (ModuleGraph) #else import ByteCodeTypes #endif @@ -244,5 +244,8 @@ instance NFData HomeModLinkable where instance NFData (HsExpr (GhcPass 'Renamed)) where rnf = rwhnf +instance NFData (Pat (GhcPass 'Renamed)) where + rnf = rwhnf + instance NFData Extension where rnf = rwhnf 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 1045fa5782..49e0179849 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 @@ -19,6 +19,11 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server +flag pedantic + description: Enable -Werror + default: False + manual: True + common warnings ghc-options: -Wall @@ -40,9 +45,13 @@ library , ghc-boot-th , unordered-containers , containers + , aeson hs-source-dirs: src default-language: Haskell2010 + if flag(pedantic) + ghc-options: -Werror + test-suite tests import: warnings 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 c604f13b65..3dfac08667 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,40 +1,49 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# 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 ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor , Log ) where -import Control.Lens ((^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Data.Functor ((<&>)) -import Data.Generics (GenericQ, everything, extQ, - mkQ) +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Maybe +import Data.Aeson (toJSON) +import Data.Generics (GenericQ, everything, + everythingBut, extQ, mkQ) +import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, - listToMaybe, maybeToList) + maybeToList) import Data.Text (Text) -import Development.IDE (IdeState, NormalizedFilePath, - Pretty (..), Recorder (..), - Rules, WithPriority (..), - realSrcSpanToRange) +import Data.Unique (hashUnique, newUnique) + +import Control.Monad (replicateM) +import Development.IDE (IdeState, Pretty (..), Range, + Recorder (..), Rules, + WithPriority (..), + defineNoDiagnostics, + realSrcSpanToRange, viaShow) import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) -import Development.IDE.Core.Shake (define, use) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsExpansion (HsExpanded), + HsExpr (XExpr), HsRecFields (..), LPat, Outputable, getLoc, recDotDot, unLoc) @@ -61,118 +70,112 @@ import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), import GHC.Generics (Generic) import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) -import Ide.Plugin.Error (PluginError, - getNormalizedFilePathE) +import Ide.Plugin.Error (PluginError (PluginStaleResolve), + getNormalizedFilePathE, + handleMaybe) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) + ResolveFunction, + defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..), SMethod (..)) +import Language.LSP.Protocol.Message (Method (..)) import Language.LSP.Protocol.Types (CodeAction (..), CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), Command, TextEdit (..), WorkspaceEdit (WorkspaceEdit), - fromNormalizedUri, - normalizedFilePathToUri, type (|?) (InL, InR)) data Log = LogShake Shake.Log | LogCollectedRecords [RecordInfo] - | LogRenderedRecords [RenderedRecordInfo] + | LogRenderedRecords [TextEdit] + | forall a. (Pretty a) => LogResolve a + instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs - LogRenderedRecords recs -> "Rendered records:" <+> pretty recs + LogRenderedRecords recs -> "Rendered records:" <+> viaShow recs + LogResolve msg -> pretty msg descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider - , pluginRules = collectRecordsRule recorder *> collectNamesRule +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + in (defaultPluginDescriptor plId) + { pluginHandlers = caHandlers + , pluginCommands = carCommands + , pluginRules = collectRecordsRule recorder } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = do +codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) - pragma <- getFirstPragma pId ideState nfp - CRR recMap exts <- collectRecords' ideState nfp - let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) + CRR{..} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions - where - mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction - mkCodeAction nfp exts pragma rec = InR CodeAction - { _title = mkCodeActionTitle exts + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ mkWorkspaceEdit nfp edits + , _edit = Nothing , _command = Nothing - , _data_ = Nothing + , _data_ = Just $ toJSON uid } - where - edits = mkTextEdit rec : maybeToList pragmaEdit - - mkTextEdit :: RenderedRecordInfo -> TextEdit - mkTextEdit (RenderedRecordInfo ss r) = TextEdit (realSrcSpanToRange ss) r - - pragmaEdit :: Maybe TextEdit - pragmaEdit = if NamedFieldPuns `elem` exts - then Nothing - else Just $ insertNewPragma pragma NamedFieldPuns - - mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit - mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing - where - changes = Just $ Map.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) edits - - mkCodeActionTitle :: [Extension] -> Text - mkCodeActionTitle exts = - if NamedFieldPuns `elem` exts - then title - else title <> " (needs extension: NamedFieldPuns)" - where - title = "Expand record wildcard" -collectRecordsRule :: Recorder (WithPriority Log) -> Rules () -collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> - use TypeCheck nfp >>= \case - Nothing -> pure ([], Nothing) - Just tmr -> do - let exts = getEnabledExtensions tmr - recs = getRecords tmr - logWith recorder Debug (LogCollectedRecords recs) - 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) +codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve +codeActionResolveProvider ideState pId ca uri uid = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId ideState nfp + CRR{..} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve + let edits = maybeToList (renderRecordInfo nameMap record) + <> maybeToList (pragmaEdit enabledExtensions pragma) + pure $ ca & L.edit ?~ mkWorkspaceEdit edits + where + mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit + mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing + pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit + pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns +collectRecordsRule :: Recorder (WithPriority Log) -> Rules () +collectRecordsRule recorder = + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + let recs = getRecords tmr + logWith recorder Debug (LogCollectedRecords recs) + uniques <- liftIO $ replicateM (length recs) (hashUnique <$> newUnique) + let recsWithUniques = zip uniques recs + crCodeActions = RangeMap.fromList' (toRangeAndUnique <$> recsWithUniques) + crCodeActionResolve = IntMap.fromList recsWithUniques + nameMap = getNames tmr + enabledExtensions = getEnabledExtensions tmr + pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where getEnabledExtensions :: TcModuleResult -> [Extension] getEnabledExtensions = getExtensions . tmrParsed + toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) 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 -> NameMap @@ -185,33 +188,21 @@ instance Hashable CollectRecords instance NFData CollectRecords data CollectRecordsResult = CRR - { recordInfos :: RangeMap RenderedRecordInfo - , enabledExtensions :: [Extension] + { crCodeActions :: RangeMap Int + , crCodeActionResolve :: IntMap.IntMap RecordInfo + , nameMap :: NameMap + , enabledExtensions :: [Extension] } deriving (Generic) instance NFData CollectRecordsResult +instance NFData RecordInfo instance Show CollectRecordsResult where show _ = "" 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 -- As with `GhcExtension`, this newtype exists mostly to attach -- an `NFData` instance to `UniqFM`.(without resorting to creating an orphan instance). @@ -223,25 +214,19 @@ instance NFData NameMap where data RecordInfo = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + deriving (Generic) instance Pretty RecordInfo where pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) -data RenderedRecordInfo = RenderedRecordInfo - { renderedSrcSpan :: RealSrcSpan - , renderedRecord :: Text - } - deriving (Generic) - -instance Pretty RenderedRecordInfo where - pretty (RenderedRecordInfo ss r) = pretty (printOutputable ss) <> ":" <+> pretty r - -instance NFData RenderedRecordInfo +recordInfoToRange :: RecordInfo -> Range +recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss +recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss -renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo -renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat -renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr +renderRecordInfo :: NameMap -> RecordInfo -> Maybe TextEdit +renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr -- | 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 @@ -323,7 +308,7 @@ showRecordCon expr@(RecordCon _ _ flds) = showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] -collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) +collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons) -- | 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 @@ -340,25 +325,27 @@ collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `e collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) -getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo +getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +-- When we stumble upon an occurrence of HsExpanded, we only want to follow a +-- single branch. We do this here, by explicitly returning occurrences from +-- traversing the original branch, and returning True, which keeps syb from +-- implicitly continuing to traverse. +getRecCons (unLoc -> XExpr (HsExpanded _ expanded)) = (collectRecords expanded, True) getRecCons e@(unLoc -> RecordCon _ _ flds) - | isJust (rec_dotdot flds) = mkRecInfo e + | isJust (rec_dotdot flds) = (mkRecInfo e, False) where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo - mkRecInfo expr = listToMaybe + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo expr = [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] -getRecCons _ = Nothing +getRecCons _ = ([], False) -getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo +getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) - | isJust (rec_dotdot flds) = mkRecInfo conPat + | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) where - mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo - mkRecInfo pat = listToMaybe + mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] -getRecPatterns _ = Nothing +getRecPatterns _ = ([], False) -collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectRecordsResult -collectRecords' ideState = runActionE "ExplicitFields" ideState - . useE CollectRecords From 4b77fe47161eb90505a82dcf1b669a9f97899881 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 9 Aug 2023 18:15:44 +0300 Subject: [PATCH 02/10] render shouldn't fail, added tests --- .../src/Ide/Plugin/ExplicitFields.hs | 5 +-- .../test/Main.hs | 16 ++++++--- .../test/testdata/HsExpanded1.expected.hs | 18 ++++++++++ .../test/testdata/HsExpanded1.hs | 17 +++++++++ .../test/testdata/HsExpanded2.expected.hs | 35 +++++++++++++++++++ .../test/testdata/HsExpanded2.hs | 34 ++++++++++++++++++ 6 files changed, 118 insertions(+), 7 deletions(-) create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs 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 3dfac08667..fb5c68605a 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 @@ -70,7 +70,7 @@ import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), import GHC.Generics (Generic) import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) -import Ide.Plugin.Error (PluginError (PluginStaleResolve), +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), getNormalizedFilePathE, handleMaybe) import Ide.Plugin.RangeMap (RangeMap) @@ -143,7 +143,8 @@ codeActionResolveProvider ideState pId ca uri uid = do pragma <- getFirstPragma pId ideState nfp CRR{..} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve - let edits = maybeToList (renderRecordInfo nameMap record) + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record + let edits = [rendered] <> maybeToList (pragmaEdit enabledExtensions pragma) pure $ ca & L.edit ?~ mkWorkspaceEdit edits where diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index abbf3d8809..2195f79fc2 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -27,6 +27,8 @@ test = testGroup "explicit-fields" , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "HsExpanded1" "HsExpanded1" 16 5 16 15 + , mkTest "HsExpanded2" "HsExpanded2" 32 7 32 18 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 @@ -41,18 +43,22 @@ mkTestNoAction title fp x1 y1 x2 y2 = actions <- getExplicitFieldsActions doc x1 y1 x2 y2 liftIO $ actions @?= [] -mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree -mkTest title fp x1 y1 x2 y2 = - goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do - (act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 +mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestWithCount cnt title fp x1 y1 x2 y2 = + goldenWithHaskellAndCaps codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 + liftIO $ length acts @?= cnt executeCodeAction act +mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTest = mkTestWithCount 1 + getExplicitFieldsActions :: TextDocumentIdentifier -> UInt -> UInt -> UInt -> UInt -> Session [CodeAction] getExplicitFieldsActions doc x1 y1 x2 y2 = - findExplicitFieldsAction <$> getCodeActions doc range + findExplicitFieldsAction <$> getAndResolveCodeActions doc range where range = Range (Position x1 y1) (Position x2 y2) diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs new file mode 100644 index 0000000000..14262c19fe --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# Language OverloadedRecordDot #-} +{-# LANGUAGE NamedFieldPuns #-} +module HsExpanded1 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> Int +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {foo, bar, baz}.foo \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs new file mode 100644 index 0000000000..98c086983e --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# Language OverloadedRecordDot #-} +module HsExpanded1 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> Int +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {..}.foo \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs new file mode 100644 index 0000000000..e549601b91 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NamedFieldPuns #-} +module HsExpanded2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +data YourRec = YourRec + { foo2 :: MyRec + , bar2 :: Int + , baz2 :: Char + } + +myRecExample = MyRec {..} + where + foo = 5 + bar = 6 + baz = 'a' + +yourRecExample = YourRec {..} + where + foo2 = myRecExample + bar2 = 5 + baz2 = 'a' + +convertMe :: () -> Int +convertMe _ = + (let MyRec{..} = myRecExample + YourRec {foo2, bar2, baz2} = yourRecExample + in foo2).foo \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs new file mode 100644 index 0000000000..168efebab0 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot #-} +module HsExpanded2 where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +data YourRec = YourRec + { foo2 :: MyRec + , bar2 :: Int + , baz2 :: Char + } + +myRecExample = MyRec {..} + where + foo = 5 + bar = 6 + baz = 'a' + +yourRecExample = YourRec {..} + where + foo2 = myRecExample + bar2 = 5 + baz2 = 'a' + +convertMe :: () -> Int +convertMe _ = + (let MyRec{..} = myRecExample + YourRec{..} = yourRecExample + in foo2).foo \ No newline at end of file From a3b0faccf7640abaf9f2b58262b2ca7a6f76fed0 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 9 Aug 2023 18:37:42 +0300 Subject: [PATCH 03/10] Improved comments --- ghcide/src/Development/IDE/GHC/Orphans.hs | 3 + .../src/Ide/Plugin/ExplicitFields.hs | 74 +++++++++++-------- 2 files changed, 45 insertions(+), 32 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 3000133da2..9ec902893c 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -249,3 +249,6 @@ instance NFData (Pat (GhcPass 'Renamed)) where instance NFData Extension where rnf = rwhnf + +instance NFData (UniqFM Name [Name]) where + rnf (ufmToIntMap -> m) = rnf m 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 fb5c68605a..bb3c223cc9 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 @@ -8,7 +8,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -58,12 +57,11 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), hs_valds, lookupUFM, mapConPatDetail, mapLoc, pattern RealSrcSpan, - plusUFM_C, ufmToIntMap, - unitUFM) + plusUFM_C, unitUFM) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) +import Development.IDE.Graph.Classes (Hashable, NFData) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) @@ -118,7 +116,9 @@ descriptor recorder plId = codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) - CRR{..} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + CRR {crCodeActions, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- All we need to build a code action is the list of extensions, and a int to + -- allow us to resolve it later. let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions where @@ -141,8 +141,11 @@ codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionReso codeActionResolveProvider ideState pId ca uri uid = do nfp <- getNormalizedFilePathE uri pragma <- getFirstPragma pId ideState nfp - CRR{..} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + CRR {crCodeActionResolve, nameMap, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- If we are unable to find the unique id in our IntMap of records, it means + -- that this resolve is stale. record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve + -- We should never fail to render rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record let edits = [rendered] <> maybeToList (pragmaEdit enabledExtensions pragma) @@ -161,9 +164,14 @@ collectRecordsRule recorder = tmr <- useMT TypeCheck nfp let recs = getRecords tmr logWith recorder Debug (LogCollectedRecords recs) + -- We want a list of unique numbers to link our the original code action we + -- give out, with the actual record info that we resolve it to. uniques <- liftIO $ replicateM (length recs) (hashUnique <$> newUnique) let recsWithUniques = zip uniques recs + -- For creating the code actions, a RangeMap of unique ids crCodeActions = RangeMap.fromList' (toRangeAndUnique <$> recsWithUniques) + -- For resolving the code actions, a IntMap which links the unique id to + -- the relevant record info. crCodeActionResolve = IntMap.fromList recsWithUniques nameMap = getNames tmr enabledExtensions = getEnabledExtensions tmr @@ -179,8 +187,8 @@ getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. -getNames :: TcModuleResult -> NameMap -getNames (tmrRenamed -> (group,_,_,_)) = NameMap (collectNames group) +getNames :: TcModuleResult -> UniqFM Name [Name] +getNames (tmrRenamed -> (group,_,_,_)) = collectNames group data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -188,10 +196,20 @@ data CollectRecords = CollectRecords instance Hashable CollectRecords instance NFData CollectRecords +-- |The result of our map, this record includes everything we need to provide +-- code actions and resolve them later data CollectRecordsResult = CRR - { crCodeActions :: RangeMap Int + { -- |For providing the code action we need the unique id (Int) in a RangeMap + crCodeActions :: RangeMap Int + -- |For resolving the code action we need to link the unique id we + -- previously gave out with the record info that we use to make the edit + -- with. , crCodeActionResolve :: IntMap.IntMap RecordInfo - , nameMap :: NameMap + -- |The name map allows us to prune unused record fields (some of the time) + , nameMap :: UniqFM Name [Name] + -- |We need to make sure NamedFieldPuns is enabled, if it's not we need to + -- add that to the text edit. (In addition we use it in creating the code + -- action title) , enabledExtensions :: [Extension] } deriving (Generic) @@ -204,14 +222,6 @@ instance Show CollectRecordsResult where type instance RuleResult CollectRecords = CollectRecordsResult - --- As with `GhcExtension`, this newtype exists mostly to attach --- an `NFData` instance to `UniqFM`.(without resorting to creating an orphan instance). -newtype NameMap = NameMap (UniqFM Name [Name]) - -instance NFData NameMap where - rnf (NameMap (ufmToIntMap -> m)) = rnf m - data RecordInfo = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) @@ -225,7 +235,7 @@ recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss -renderRecordInfo :: NameMap -> RecordInfo -> Maybe TextEdit +renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr @@ -234,20 +244,20 @@ renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$ -- 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 -> NameMap -> Bool -referencedIn name (NameMap names) = maybe True hasNonBindingOcc $ lookupUFM names name +referencedIn :: Name -> UniqFM Name [Name] -> Bool +referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name where hasNonBindingOcc :: [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) -> NameMap -> [a] -> [a] +filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) preprocessRecordPat :: p ~ GhcPass 'Renamed - => NameMap + => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) @@ -258,7 +268,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) (NameMap emptyUFM) +preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM -- This function does two things: -- 1) Tweak the AST type so that the pretty-printed record is in the @@ -279,7 +289,7 @@ preprocessRecordCon = preprocessRecord (const Nothing) (NameMap emptyUFM) preprocessRecord :: p ~ GhcPass c => (LocatedA (HsRecField p arg) -> Maybe Name) - -> NameMap + -> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } @@ -297,7 +307,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)) => NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) @@ -314,14 +324,12 @@ collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` get -- | 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). +-- each individual list of names contains the binding occurrence, along with +-- all the occurrences at the use-sites (if there are any). -- -- @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 +-- internally uses 'IntMap'. More information regarding 'UniqFM' can be found in -- the GHC source. collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) @@ -330,7 +338,9 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- When we stumble upon an occurrence of HsExpanded, we only want to follow a -- single branch. We do this here, by explicitly returning occurrences from -- traversing the original branch, and returning True, which keeps syb from --- implicitly continuing to traverse. +-- implicitly continuing to traverse. In addition, we have to return a list, +-- because there is a possibility that there were be more than one result per +-- branch getRecCons (unLoc -> XExpr (HsExpanded _ expanded)) = (collectRecords expanded, True) getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) From 93f2c6cf7a7583ed38c91b5aba2bc6fbcce05033 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 9 Aug 2023 18:42:26 +0300 Subject: [PATCH 04/10] Remove unused language extensions --- .../src/Ide/Plugin/ExplicitFields.hs | 2 -- 1 file changed, 2 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 bb3c223cc9..d71c83cfb7 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,7 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} From 9e717843318a1b21cb7757d73e602fab718c4a21 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 11 Aug 2023 20:12:57 +0300 Subject: [PATCH 05/10] 8.10 and 9.0 fixes and separate collect names into it's own rule --- ghcide/src/Development/IDE/GHC/Orphans.hs | 3 +- .../hls-explicit-record-fields-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitFields.hs | 36 ++++++++++++++++--- .../test/Main.hs | 5 ++- 4 files changed, 37 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 9ec902893c..7d8311dddd 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -12,6 +12,7 @@ module Development.IDE.GHC.Orphans() where #if MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation #endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Data.Bag import GHC.Data.FastString @@ -23,7 +24,7 @@ import GHC.Unit.Info import GHC.Utils.Outputable #else import Bag -import GhcPlugins +import GhcPlugins hiding (UniqFM) import qualified StringBuffer as SB import Unique (getKey) #endif 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 49e0179849..7cf2e750ee 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 @@ -34,6 +34,7 @@ library -- other-extensions: build-depends: , base >=4.12 && <5 + , ghc , ghcide == 2.1.0.0 , hls-plugin-api == 2.1.0.0 , lsp 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 d71c83cfb7..381dd0b611 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} @@ -39,7 +40,6 @@ import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpansion (HsExpanded), HsExpr (XExpr), HsRecFields (..), LPat, Outputable, getLoc, @@ -86,6 +86,9 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) +#if MIN_VERSION_ghc(9,0,0) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) +#endif data Log = LogShake Shake.Log @@ -108,7 +111,7 @@ descriptor recorder plId = in (defaultPluginDescriptor plId) { pluginHandlers = caHandlers , pluginCommands = carCommands - , pluginRules = collectRecordsRule recorder + , pluginRules = collectRecordsRule recorder *> collectNamesRule } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction @@ -160,6 +163,7 @@ collectRecordsRule :: Recorder (WithPriority Log) -> Rules () collectRecordsRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do tmr <- useMT TypeCheck nfp + (CNR nameMap) <- useMT CollectNames nfp let recs = getRecords tmr logWith recorder Debug (LogCollectedRecords recs) -- We want a list of unique numbers to link our the original code action we @@ -171,7 +175,6 @@ collectRecordsRule recorder = -- For resolving the code actions, a IntMap which links the unique id to -- the relevant record info. crCodeActionResolve = IntMap.fromList recsWithUniques - nameMap = getNames tmr enabledExtensions = getEnabledExtensions tmr pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where @@ -183,6 +186,11 @@ getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds +collectNamesRule :: Rules () +collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + pure (CNR (getNames tmr)) + -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. getNames :: TcModuleResult -> UniqFM Name [Name] @@ -220,6 +228,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 (UniqFM Name [Name]) + deriving (Generic) + +instance NFData CollectNamesResult + +instance Show CollectNamesResult where + show _ = "" + +type instance RuleResult CollectNames = CollectNamesResult + data RecordInfo = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) @@ -339,7 +363,11 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- implicitly continuing to traverse. In addition, we have to return a list, -- because there is a possibility that there were be more than one result per -- branch -getRecCons (unLoc -> XExpr (HsExpanded _ expanded)) = (collectRecords expanded, True) + +#if MIN_VERSION_ghc(9,0,0) +getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +#endif + getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 2195f79fc2..46b70709c3 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -11,7 +11,6 @@ import qualified Ide.Plugin.ExplicitFields as ExplicitFields import System.FilePath ((<.>), ()) import Test.Hls - main :: IO () main = defaultTestRunner test @@ -27,8 +26,8 @@ test = testGroup "explicit-fields" , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 - , mkTest "HsExpanded1" "HsExpanded1" 16 5 16 15 - , mkTest "HsExpanded2" "HsExpanded2" 32 7 32 18 + , knownBrokenForGhcVersions [GHC810, GHC90] "Neither version supports overloaded record dot" $ mkTest "HsExpanded1" "HsExpanded1" 16 5 16 15 + , knownBrokenForGhcVersions [GHC810, GHC90] "Neither version supports overloaded record dot" $mkTest "HsExpanded2" "HsExpanded2" 32 7 32 18 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 From cc25dae6a8725111ed4fd8f2fe9a5a01118e1013 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 18 Aug 2023 17:23:52 +0300 Subject: [PATCH 06/10] fix flags and add Resolve module haddock --- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 12 ++++++++++++ .../src/Ide/Plugin/ExplicitFields.hs | 4 ++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 5a0f7fa793..235f29e042 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -6,6 +6,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-| This module currently includes helper functions to provide fallback support +to code actions that use resolve in HLS. The difference between the two +functions for code actions that don't support resolve is that +mkCodeActionHandlerWithResolve will immediately resolve your code action before +sending it on to the client, while mkCodeActionWithResolveAndCommand will turn +your resolve into a command. + +General support for resolve in HLS can be used with mkResolveHandler from +Ide.Types. Resolve theoretically should allow us to delay computation of parts +of the request till the client needs it, allowing us to answer requests faster +and with less resource usage. +-} module Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve, mkCodeActionWithResolveAndCommand) where 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 381dd0b611..a093349383 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 @@ -40,7 +40,6 @@ import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpr (XExpr), HsRecFields (..), LPat, Outputable, getLoc, recDotDot, unLoc) @@ -87,7 +86,8 @@ import Language.LSP.Protocol.Types (CodeAction (..), type (|?) (InL, InR)) #if MIN_VERSION_ghc(9,0,0) -import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded), + HsExpr (XExpr)) #endif data Log From b1dd7e11326937f05acd3cf2b7cd7cf8b674c6c5 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 23 Aug 2023 13:58:50 +0300 Subject: [PATCH 07/10] better tests --- .../test/Main.hs | 4 +- .../test/testdata/HsExpanded1.expected.hs | 25 +++++------ .../test/testdata/HsExpanded1.hs | 26 ++++++------ .../test/testdata/HsExpanded2.expected.hs | 40 +++++++----------- .../test/testdata/HsExpanded2.hs | 41 ++++++++----------- 5 files changed, 60 insertions(+), 76 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 46b70709c3..0efa16def5 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -26,8 +26,8 @@ test = testGroup "explicit-fields" , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 - , knownBrokenForGhcVersions [GHC810, GHC90] "Neither version supports overloaded record dot" $ mkTest "HsExpanded1" "HsExpanded1" 16 5 16 15 - , knownBrokenForGhcVersions [GHC810, GHC90] "Neither version supports overloaded record dot" $mkTest "HsExpanded2" "HsExpanded2" 32 7 32 18 + , knownBrokenForGhcVersions [GHC810] "HsExpansion is new as of 9.0" $ mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , knownBrokenForGhcVersions [GHC810] "HsExpansion is now as of 9.0" $ mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs index 14262c19fe..2e970a5f35 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE RecordWildCards #-} -{-# Language OverloadedRecordDot #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE NamedFieldPuns #-} + module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z data MyRec = MyRec - { foo :: Int - , bar :: Int - , baz :: Char - } + { foo :: Int } + +myRecExample = MyRec 5 -convertMe :: () -> Int -convertMe _ = - let foo = 3 - bar = 5 - baz = 'a' - in MyRec {foo, bar, baz}.foo \ No newline at end of file +convertMe :: Int +convertMe = + if (let MyRec {foo} = myRecExample + in foo) then 1 else 2 \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs index 98c086983e..8c0f2c341e 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE RecordWildCards #-} -{-# Language OverloadedRecordDot #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z data MyRec = MyRec - { foo :: Int - , bar :: Int - , baz :: Char - } + { foo :: Int } + +myRecExample = MyRec 5 -convertMe :: () -> Int -convertMe _ = - let foo = 3 - bar = 5 - baz = 'a' - in MyRec {..}.foo \ No newline at end of file +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + in foo) then 1 else 2 \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs index e549601b91..497752867c 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs @@ -1,35 +1,25 @@ -{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE NamedFieldPuns #-} + module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z data MyRec = MyRec - { foo :: Int - , bar :: Int - , baz :: Char - } + { foo :: Int } data YourRec = YourRec - { foo2 :: MyRec - , bar2 :: Int - , baz2 :: Char - } + { bar :: Int } -myRecExample = MyRec {..} - where - foo = 5 - bar = 6 - baz = 'a' +myRecExample = MyRec 5 -yourRecExample = YourRec {..} - where - foo2 = myRecExample - bar2 = 5 - baz2 = 'a' +yourRecExample = YourRec 3 -convertMe :: () -> Int -convertMe _ = - (let MyRec{..} = myRecExample - YourRec {foo2, bar2, baz2} = yourRecExample - in foo2).foo \ No newline at end of file +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {bar} = yourRecExample + in bar) then 1 else 2 \ No newline at end of file diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs index 168efebab0..7126fc0199 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs @@ -1,34 +1,25 @@ -{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z data MyRec = MyRec - { foo :: Int - , bar :: Int - , baz :: Char - } + { foo :: Int } data YourRec = YourRec - { foo2 :: MyRec - , bar2 :: Int - , baz2 :: Char - } + { bar :: Int } -myRecExample = MyRec {..} - where - foo = 5 - bar = 6 - baz = 'a' +myRecExample = MyRec 5 -yourRecExample = YourRec {..} - where - foo2 = myRecExample - bar2 = 5 - baz2 = 'a' +yourRecExample = YourRec 3 -convertMe :: () -> Int -convertMe _ = - (let MyRec{..} = myRecExample - YourRec{..} = yourRecExample - in foo2).foo \ No newline at end of file +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {..} = yourRecExample + in bar) then 1 else 2 \ No newline at end of file From d9067fad35442ac23a986a0e2d8b046b08d8ca7f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 24 Aug 2023 15:02:45 +0300 Subject: [PATCH 08/10] works for all ghc versions --- plugins/hls-explicit-record-fields-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index 0efa16def5..bbbdab77fd 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -26,8 +26,8 @@ test = testGroup "explicit-fields" , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 - , knownBrokenForGhcVersions [GHC810] "HsExpansion is new as of 9.0" $ mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 - , knownBrokenForGhcVersions [GHC810] "HsExpansion is now as of 9.0" $ mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 From d7391e12b651f6df0403d2288e061e9f2109ccbd Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 24 Aug 2023 15:26:39 +0300 Subject: [PATCH 09/10] Fix flags --- ghcide/src/Development/IDE/GHC/Orphans.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index a4153db19a..0440e644f4 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -29,7 +29,6 @@ import Unique (getKey) #endif #if MIN_VERSION_ghc(9,0,0) -import GHC (ModuleGraph) import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString From b903160983686b0557f396eb88a1fbc64b11d7a8 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 24 Aug 2023 18:09:26 +0300 Subject: [PATCH 10/10] ignore incomplete record updates in explicit record fields --- .../hls-explicit-record-fields-plugin.cabal | 1 + 1 file changed, 1 insertion(+) 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 7cf2e750ee..612e97e12f 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 @@ -52,6 +52,7 @@ library if flag(pedantic) ghc-options: -Werror + -Wwarn=incomplete-record-updates test-suite tests import: warnings