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.

Author: pepeiborra

Diff for: src/Ide/Plugin/Retrie.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
@@ -45,7 +46,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 +98,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 +123,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 +145,7 @@ runRetrieCmd lsp state RunRetrieParams {..} =
         (hscEnv session)
         rewrites
         (toNormalizedFilePath originatingFile)
+        restrictToOriginatingFile
     unless (null errors) $
       sendFunc lsp $
         NotShowMessage $
@@ -228,17 +235,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 +265,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 +285,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 +299,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 +347,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,10 +367,11 @@ callRetrie state session rewrites origin = do
                       { ms_hspp_buf =
                           Just (stringToStringBuffer contents)
                       }
-              (_, parsed) <-
+              logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
+              (_, !parsed) <-
                 runGhcEnv session (parseModule ms')
                   `catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
-              (fixities, parsed) <- fixFixities f (fixAnns parsed)
+              (!fixities, !parsed) <- fixFixities f (fixAnns parsed)
               return (fixities, parsed)
 
         contents <- do
@@ -359,7 +389,7 @@ callRetrie state session rewrites origin = do
                   return res
             res <- parseCPP parseModule contents
             fixities <- readIORef fixitiesRef
-            return (fixities, res)
+            return $! (fixities, res)
           else do
             (fixities, pm) <- reuseParsedModule nt
             return (fixities, NoCPP pm)
@@ -368,7 +398,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