Skip to content

Commit c1c3680

Browse files
pepeiborrapepeiborra
authored
Add single file rewrites and ignore unknown files (#321)
* 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. * rearrange imports
1 parent 4990117 commit c1c3680

File tree

1 file changed

+74
-36
lines changed

1 file changed

+74
-36
lines changed

‎src/Ide/Plugin/Retrie.hs

Lines changed: 74 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717

1818
module Ide.Plugin.Retrie (descriptor) where
1919

20+
import Control.Concurrent.Extra (readVar)
2021
import Control.Exception.Safe (Exception (..), SomeException,
2122
catch, throwIO, try)
2223
import Control.Monad (forM, unless)
@@ -29,7 +30,9 @@ import Data.Aeson.Types (FromJSON)
2930
import Data.Bifunctor (Bifunctor (first), second)
3031
import Data.Coerce
3132
import Data.Either (partitionEithers)
33+
import Data.Hashable (unhashed)
3234
import qualified Data.HashMap.Strict as HM
35+
import qualified Data.HashSet as Set
3336
import Data.IORef.Extra (atomicModifyIORef'_, newIORef,
3437
readIORef)
3538
import Data.List.Extra (nubOrdOn)
@@ -47,18 +50,21 @@ import Development.IDE.Core.RuleTypes as Ghcide (GetModIface (..),
4750
tmrModule)
4851
import Development.IDE.Core.Shake (IdeRule,
4952
IdeState (shakeExtras),
53+
ideLogger, knownFilesVar,
5054
runIdeAction, use,
5155
useWithStaleFast, use_)
52-
import Development.IDE.GHC.Error (realSrcSpanToRange, isInsideSrcSpan)
56+
import Development.IDE.GHC.Error (isInsideSrcSpan,
57+
realSrcSpanToRange)
5358
import Development.IDE.GHC.Util (hscEnv, prettyPrint, runGhcEnv)
5459
import Development.IDE.Types.Location
60+
import Development.IDE.Types.Logger (Logger (logPriority),
61+
Priority (..))
5562
import Development.Shake (RuleResult)
5663
import GHC (GenLocated (L), GhcRn,
5764
HsBindLR (FunBind),
5865
HsGroup (..),
5966
HsValBindsLR (..), HscEnv, IdP,
6067
LRuleDecls,
61-
mi_fixities,
6268
ModSummary (ModSummary, ms_hspp_buf, ms_mod),
6369
NHsValBindsLR (..),
6470
ParsedModule (..),
@@ -68,8 +74,9 @@ import GHC (GenLocated (L), GhcRn,
6874
TyClDecl (SynDecl),
6975
TyClGroup (..),
7076
TypecheckedModule (..), fun_id,
71-
moduleNameString, parseModule,
72-
rds_rules, srcSpanFile)
77+
mi_fixities, moduleNameString,
78+
parseModule, rds_rules,
79+
srcSpanFile)
7380
import GHC.Generics (Generic)
7481
import GhcPlugins (Outputable,
7582
SourceText (NoSourceText),
@@ -114,11 +121,12 @@ retrieCommand =
114121

115122
-- | Parameters for the runRetrie PluginCommand.
116123
data RunRetrieParams = RunRetrieParams
117-
{ description :: T.Text,
124+
{ description :: T.Text,
118125
-- | rewrites for Retrie
119-
rewrites :: [Either ImportSpec RewriteSpec],
126+
rewrites :: [Either ImportSpec RewriteSpec],
120127
-- | Originating file
121-
originatingFile :: String -- NormalizedFilePath
128+
originatingFile :: String,
129+
restrictToOriginatingFile :: Bool
122130
}
123131
deriving (Eq, Show, Generic, FromJSON, ToJSON)
124132

@@ -139,6 +147,7 @@ runRetrieCmd lsp state RunRetrieParams {..} =
139147
(hscEnv session)
140148
rewrites
141149
(toNormalizedFilePath originatingFile)
150+
restrictToOriginatingFile
142151
unless (null errors) $
143152
sendFunc lsp $
144153
NotShowMessage $
@@ -228,17 +237,24 @@ suggestBindRewrites originatingFile pos ms_mod (FunBind {fun_id = L l' rdrName,
228237
let ideclAsString = moduleNameString . fst <$> isQual_maybe r,
229238
let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r)
230239
]
231-
in [ let rewrites =
232-
[Right $ Unfold (qualify ms_mod pprName)]
233-
++ map Left imports
234-
description = "Unfold " <> pprNameText
235-
in (description, CodeActionRefactorInline, RunRetrieParams {..}),
240+
unfoldRewrite restrictToOriginatingFile =
241+
let rewrites =
242+
[Right $ Unfold (qualify ms_mod pprName)]
243+
++ map Left imports
244+
description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile
245+
in (description, CodeActionRefactorInline, RunRetrieParams {..})
246+
foldRewrite restrictToOriginatingFile =
236247
let rewrites = [Right $ Fold (qualify ms_mod pprName)]
237-
description = "Fold " <> pprNameText
248+
description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile
238249
in (description, CodeActionRefactorExtract, RunRetrieParams {..})
239-
]
250+
in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]
251+
where
240252
suggestBindRewrites _ _ _ _ = []
241253

254+
describeRestriction :: IsString p => Bool -> p
255+
describeRestriction restrictToOriginatingFile =
256+
if restrictToOriginatingFile then " in current file" else ""
257+
242258
-- TODO add imports to the rewrite
243259
suggestTypeRewrites ::
244260
(Outputable (IdP pass)) =>
@@ -251,13 +267,15 @@ suggestTypeRewrites originatingFile pos ms_mod (SynDecl {tcdLName = L l rdrName}
251267
| pos `isInsideSrcSpan` l =
252268
let pprName = prettyPrint rdrName
253269
pprNameText = T.pack pprName
254-
in [ let rewrites = [Right $ TypeForward (qualify ms_mod pprName)]
255-
description = "Unfold " <> pprNameText
256-
in (description, CodeActionRefactorInline, RunRetrieParams {..}),
270+
unfoldRewrite restrictToOriginatingFile =
271+
let rewrites = [Right $ TypeForward (qualify ms_mod pprName)]
272+
description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile
273+
in (description, CodeActionRefactorInline, RunRetrieParams {..})
274+
foldRewrite restrictToOriginatingFile =
257275
let rewrites = [Right $ TypeBackward (qualify ms_mod pprName)]
258-
description = "Fold " <> pprNameText
276+
description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile
259277
in (description, CodeActionRefactorExtract, RunRetrieParams {..})
260-
]
278+
in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]
261279
suggestTypeRewrites _ _ _ _ = []
262280

263281
-- TODO add imports to the rewrite
@@ -269,21 +287,11 @@ suggestRuleRewrites ::
269287
[(T.Text, CodeActionKind, RunRetrieParams)]
270288
suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) =
271289
concat
272-
[ [ let rewrites =
273-
[Right $ RuleForward (qualify ms_mod ruleName)]
274-
description = "Apply rule " <> T.pack ruleName <> " forward"
275-
in ( description,
276-
CodeActionRefactor,
277-
RunRetrieParams {..}
278-
),
279-
let rewrites =
280-
[Right $ RuleBackward (qualify ms_mod ruleName)]
281-
description = "Apply rule " <> T.pack ruleName <> " backwards"
282-
in ( description,
283-
CodeActionRefactor,
284-
RunRetrieParams {..}
285-
)
286-
]
290+
[ [ forwardRewrite ruleName True
291+
, forwardRewrite ruleName False
292+
, backwardsRewrite ruleName True
293+
, backwardsRewrite ruleName False
294+
]
287295
| L l r <- rds_rules,
288296
pos `isInsideSrcSpan` l,
289297
#if MIN_GHC_API_VERSION(8,8,0)
@@ -293,6 +301,26 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) =
293301
#endif
294302
let ruleName = unpackFS rn
295303
]
304+
where
305+
forwardRewrite ruleName restrictToOriginatingFile =
306+
let rewrites =
307+
[Right $ RuleForward (qualify ms_mod ruleName)]
308+
description = "Apply rule " <> T.pack ruleName <> " forward" <>
309+
describeRestriction restrictToOriginatingFile
310+
311+
in ( description,
312+
CodeActionRefactor,
313+
RunRetrieParams {..}
314+
)
315+
backwardsRewrite ruleName restrictToOriginatingFile =
316+
let rewrites =
317+
[Right $ RuleBackward (qualify ms_mod ruleName)]
318+
description = "Apply rule " <> T.pack ruleName <> " backwards"
319+
in ( description,
320+
CodeActionRefactor,
321+
RunRetrieParams {..}
322+
)
323+
296324
suggestRuleRewrites _ _ _ _ = []
297325

298326
qualify :: GHC.Module -> String -> String
@@ -321,8 +349,11 @@ callRetrie ::
321349
HscEnv ->
322350
[Either ImportSpec RewriteSpec] ->
323351
NormalizedFilePath ->
352+
Bool ->
324353
IO ([CallRetrieError], WorkspaceEdit)
325-
callRetrie state session rewrites origin = do
354+
callRetrie state session rewrites origin restrictToOriginatingFile = do
355+
knownFiles <- readVar $ knownFilesVar $ shakeExtras state
356+
print knownFiles
326357
let reuseParsedModule f = do
327358
pm <-
328359
useOrFail "GetParsedModule" NoParse GetParsedModule f
@@ -338,6 +369,7 @@ callRetrie state session rewrites origin = do
338369
{ ms_hspp_buf =
339370
Just (stringToStringBuffer contents)
340371
}
372+
logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
341373
(_, parsed) <-
342374
runGhcEnv session (parseModule ms')
343375
`catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
@@ -368,7 +400,13 @@ callRetrie state session rewrites origin = do
368400
target = "."
369401

370402
retrieOptions :: Retrie.Options
371-
retrieOptions = (defaultOptions target) {Retrie.verbosity = Loud}
403+
retrieOptions = (defaultOptions target)
404+
{Retrie.verbosity = Loud
405+
,Retrie.targetFiles = map fromNormalizedFilePath $
406+
if restrictToOriginatingFile
407+
then [origin]
408+
else Set.toList $ unhashed knownFiles
409+
}
372410

373411
(theImports, theRewrites) = partitionEithers rewrites
374412

0 commit comments

Comments
 (0)