From 0e04108e33df0dda8ae0a3cac5ca03df3f426091 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 15 Aug 2020 16:10:56 +0100 Subject: [PATCH 1/2] Add single file rewrites and ignore unknown files Retrie is very slow and memory hungry on modules with lots of CPP. For instance, it runs out of memory on Development.IDE.GHC.Compat. This creates problems when rewriting (particularly folding). As a low key workaround, this adds new code actions that rewrite only in the current file. Rewriting on files without a cradle is also very slowbecause it results in calls to hie-bios that fail after consulting with Cabal. Thus exclude them. --- src/Ide/Plugin/Retrie.hs | 97 +++++++++++++++++++++++++++------------- 1 file changed, 66 insertions(+), 31 deletions(-) diff --git a/src/Ide/Plugin/Retrie.hs b/src/Ide/Plugin/Retrie.hs index 1f598cebaf..07800157e7 100644 --- a/src/Ide/Plugin/Retrie.hs +++ b/src/Ide/Plugin/Retrie.hs @@ -45,7 +45,7 @@ import Development.IDE.Core.RuleTypes as Ghcide (GetModIface (..), HiFileResult (..), TypeCheck (..), tmrModule) -import Development.IDE.Core.Shake (IdeRule, +import Development.IDE.Core.Shake (ideLogger, knownFilesVar, IdeRule, IdeState (shakeExtras), runIdeAction, use, useWithStaleFast, use_) @@ -97,6 +97,10 @@ import Retrie.SYB (listify) import Retrie.Util (Verbosity (Loud)) import StringBuffer (stringToStringBuffer) import System.Directory (makeAbsolute) +import Control.Concurrent.Extra (readVar) +import Data.Hashable (unhashed) +import qualified Data.HashSet as Set +import Development.IDE.Types.Logger (Priority(..), Logger(logPriority)) descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -118,7 +122,8 @@ data RunRetrieParams = RunRetrieParams -- | rewrites for Retrie rewrites :: [Either ImportSpec RewriteSpec], -- | Originating file - originatingFile :: String -- NormalizedFilePath + originatingFile :: String, + restrictToOriginatingFile :: Bool } deriving (Eq, Show, Generic, FromJSON, ToJSON) @@ -139,6 +144,7 @@ runRetrieCmd lsp state RunRetrieParams {..} = (hscEnv session) rewrites (toNormalizedFilePath originatingFile) + restrictToOriginatingFile unless (null errors) $ sendFunc lsp $ NotShowMessage $ @@ -228,17 +234,24 @@ suggestBindRewrites originatingFile pos ms_mod (FunBind {fun_id = L l' rdrName, let ideclAsString = moduleNameString . fst <$> isQual_maybe r, let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r) ] - in [ let rewrites = - [Right $ Unfold (qualify ms_mod pprName)] - ++ map Left imports - description = "Unfold " <> pprNameText - in (description, CodeActionRefactorInline, RunRetrieParams {..}), + unfoldRewrite restrictToOriginatingFile = + let rewrites = + [Right $ Unfold (qualify ms_mod pprName)] + ++ map Left imports + description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionRefactorInline, RunRetrieParams {..}) + foldRewrite restrictToOriginatingFile = let rewrites = [Right $ Fold (qualify ms_mod pprName)] - description = "Fold " <> pprNameText + description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile in (description, CodeActionRefactorExtract, RunRetrieParams {..}) - ] + in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] + where suggestBindRewrites _ _ _ _ = [] +describeRestriction :: IsString p => Bool -> p +describeRestriction restrictToOriginatingFile = + if restrictToOriginatingFile then " in current file" else "" + -- TODO add imports to the rewrite suggestTypeRewrites :: (Outputable (IdP pass)) => @@ -251,13 +264,15 @@ suggestTypeRewrites originatingFile pos ms_mod (SynDecl {tcdLName = L l rdrName} | pos `isInsideSrcSpan` l = let pprName = prettyPrint rdrName pprNameText = T.pack pprName - in [ let rewrites = [Right $ TypeForward (qualify ms_mod pprName)] - description = "Unfold " <> pprNameText - in (description, CodeActionRefactorInline, RunRetrieParams {..}), + unfoldRewrite restrictToOriginatingFile = + let rewrites = [Right $ TypeForward (qualify ms_mod pprName)] + description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile + in (description, CodeActionRefactorInline, RunRetrieParams {..}) + foldRewrite restrictToOriginatingFile = let rewrites = [Right $ TypeBackward (qualify ms_mod pprName)] - description = "Fold " <> pprNameText + description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile in (description, CodeActionRefactorExtract, RunRetrieParams {..}) - ] + in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestTypeRewrites _ _ _ _ = [] -- TODO add imports to the rewrite @@ -269,21 +284,11 @@ suggestRuleRewrites :: [(T.Text, CodeActionKind, RunRetrieParams)] suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) = concat - [ [ let rewrites = - [Right $ RuleForward (qualify ms_mod ruleName)] - description = "Apply rule " <> T.pack ruleName <> " forward" - in ( description, - CodeActionRefactor, - RunRetrieParams {..} - ), - let rewrites = - [Right $ RuleBackward (qualify ms_mod ruleName)] - description = "Apply rule " <> T.pack ruleName <> " backwards" - in ( description, - CodeActionRefactor, - RunRetrieParams {..} - ) - ] + [ [ forwardRewrite ruleName True + , forwardRewrite ruleName False + , backwardsRewrite ruleName True + , backwardsRewrite ruleName False + ] | L l r <- rds_rules, pos `isInsideSrcSpan` l, #if MIN_GHC_API_VERSION(8,8,0) @@ -293,6 +298,26 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) = #endif let ruleName = unpackFS rn ] + where + forwardRewrite ruleName restrictToOriginatingFile = + let rewrites = + [Right $ RuleForward (qualify ms_mod ruleName)] + description = "Apply rule " <> T.pack ruleName <> " forward" <> + describeRestriction restrictToOriginatingFile + + in ( description, + CodeActionRefactor, + RunRetrieParams {..} + ) + backwardsRewrite ruleName restrictToOriginatingFile = + let rewrites = + [Right $ RuleBackward (qualify ms_mod ruleName)] + description = "Apply rule " <> T.pack ruleName <> " backwards" + in ( description, + CodeActionRefactor, + RunRetrieParams {..} + ) + suggestRuleRewrites _ _ _ _ = [] qualify :: GHC.Module -> String -> String @@ -321,8 +346,11 @@ callRetrie :: HscEnv -> [Either ImportSpec RewriteSpec] -> NormalizedFilePath -> + Bool -> IO ([CallRetrieError], WorkspaceEdit) -callRetrie state session rewrites origin = do +callRetrie state session rewrites origin restrictToOriginatingFile = do + knownFiles <- readVar $ knownFilesVar $ shakeExtras state + print knownFiles let reuseParsedModule f = do pm <- useOrFail "GetParsedModule" NoParse GetParsedModule f @@ -338,6 +366,7 @@ callRetrie state session rewrites origin = do { ms_hspp_buf = Just (stringToStringBuffer contents) } + logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t (_, parsed) <- runGhcEnv session (parseModule ms') `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) @@ -368,7 +397,13 @@ callRetrie state session rewrites origin = do target = "." retrieOptions :: Retrie.Options - retrieOptions = (defaultOptions target) {Retrie.verbosity = Loud} + retrieOptions = (defaultOptions target) + {Retrie.verbosity = Loud + ,Retrie.targetFiles = map fromNormalizedFilePath $ + if restrictToOriginatingFile + then [origin] + else Set.toList $ unhashed knownFiles + } (theImports, theRewrites) = partitionEithers rewrites From 758dd3c9689ad8e84a5af5befd9630ab61010efa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 15 Aug 2020 19:36:17 +0100 Subject: [PATCH 2/2] rearrange imports --- src/Ide/Plugin/Retrie.hs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Ide/Plugin/Retrie.hs b/src/Ide/Plugin/Retrie.hs index 07800157e7..e919d34f2c 100644 --- a/src/Ide/Plugin/Retrie.hs +++ b/src/Ide/Plugin/Retrie.hs @@ -17,6 +17,7 @@ module Ide.Plugin.Retrie (descriptor) where +import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), SomeException, catch, throwIO, try) import Control.Monad (forM, unless) @@ -29,7 +30,9 @@ import Data.Aeson.Types (FromJSON) import Data.Bifunctor (Bifunctor (first), second) import Data.Coerce import Data.Either (partitionEithers) +import Data.Hashable (unhashed) import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as Set import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (nubOrdOn) @@ -45,20 +48,23 @@ import Development.IDE.Core.RuleTypes as Ghcide (GetModIface (..), HiFileResult (..), TypeCheck (..), tmrModule) -import Development.IDE.Core.Shake (ideLogger, knownFilesVar, IdeRule, +import Development.IDE.Core.Shake (IdeRule, IdeState (shakeExtras), + ideLogger, knownFilesVar, runIdeAction, use, useWithStaleFast, use_) -import Development.IDE.GHC.Error (realSrcSpanToRange, isInsideSrcSpan) +import Development.IDE.GHC.Error (isInsideSrcSpan, + realSrcSpanToRange) import Development.IDE.GHC.Util (hscEnv, prettyPrint, runGhcEnv) import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Logger (logPriority), + Priority (..)) import Development.Shake (RuleResult) import GHC (GenLocated (L), GhcRn, HsBindLR (FunBind), HsGroup (..), HsValBindsLR (..), HscEnv, IdP, LRuleDecls, - mi_fixities, ModSummary (ModSummary, ms_hspp_buf, ms_mod), NHsValBindsLR (..), ParsedModule (..), @@ -68,8 +74,9 @@ import GHC (GenLocated (L), GhcRn, TyClDecl (SynDecl), TyClGroup (..), TypecheckedModule (..), fun_id, - moduleNameString, parseModule, - rds_rules, srcSpanFile) + mi_fixities, moduleNameString, + parseModule, rds_rules, + srcSpanFile) import GHC.Generics (Generic) import GhcPlugins (Outputable, SourceText (NoSourceText), @@ -97,10 +104,6 @@ import Retrie.SYB (listify) import Retrie.Util (Verbosity (Loud)) import StringBuffer (stringToStringBuffer) import System.Directory (makeAbsolute) -import Control.Concurrent.Extra (readVar) -import Data.Hashable (unhashed) -import qualified Data.HashSet as Set -import Development.IDE.Types.Logger (Priority(..), Logger(logPriority)) descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -118,11 +121,11 @@ retrieCommand = -- | Parameters for the runRetrie PluginCommand. data RunRetrieParams = RunRetrieParams - { description :: T.Text, + { description :: T.Text, -- | rewrites for Retrie - rewrites :: [Either ImportSpec RewriteSpec], + rewrites :: [Either ImportSpec RewriteSpec], -- | Originating file - originatingFile :: String, + originatingFile :: String, restrictToOriginatingFile :: Bool } deriving (Eq, Show, Generic, FromJSON, ToJSON)