Avoid blocking when prepping pragmas for inlay

ghcide/src/Development/IDE/Spans/Pragmas.hs

@@ -7,7 +7,8 @@ module Development.IDE.Spans.Pragmas
   , LineSplitTextEdits(..)
   , getNextPragmaInfo
   , insertNewPragma
-  , getFirstPragma ) where
+  , getFirstPragma
+  , getFirstPragmaFast ) where
 
 import           Control.Lens                    ((&), (.~))
 import           Data.Bits                       (Bits (setBit))
@@ -17,7 +18,8 @@ import           Data.Text                       (Text, pack)
 import qualified Data.Text                       as Text
 import           Data.Text.Utf16.Rope.Mixed      (Rope)
 import qualified Data.Text.Utf16.Rope.Mixed      as Rope
-import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction)
+import           Development.IDE                 (srcSpanToRange, IdeState (..), NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction, GetFileContents (..), IdeAction)
+import           Development.IDE.Core.PositionMapping (PositionMapping)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Util
 import qualified Language.LSP.Protocol.Types    as LSP
@@ -50,12 +52,27 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma =  LSP.TextEdit prag
         pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0
         pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition
 
+-- | Compute where to insert the next pragma in @nfp@.
+--
+-- Blocks the calling thread via 'runAction'.
+-- NB: Prefer 'getFirstPragmaFast' when already inside an 'IdeAction' context.
 getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo
 getFirstPragma (PluginId pId) state nfp = do
   (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp
   fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp
   pure $ getNextPragmaInfo sessionDynFlags fileContents
 
+-- | Non-blocking variant of 'getFirstPragma' for use inside 'IdeAction'.
+--
+-- Returns the pragma insertion info together with a 'PositionMapping' that
+-- translates positions in the (possibly stale) file-contents snapshot to the
+-- current editor view.
+getFirstPragmaFast :: NormalizedFilePath -> ExceptT PluginError IdeAction (NextPragmaInfo, PositionMapping)
+getFirstPragmaFast nfp = do
+  (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- useWithStaleFastE GhcSession nfp
+  ((_, fileContents), pm) <- useWithStaleFastE GetFileContents nfp
+  pure (getNextPragmaInfo sessionDynFlags fileContents,  pm)
+
 -- Pre-declaration comments parser -----------------------------------------------------
 
 -- | Each mode represents the "strongest" thing we've seen so far.

plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs

@@ -197,7 +197,8 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif
     if isInlayHintsSupported state
     then do
         nfp <- getNormalizedFilePathE _uri
-        (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp
+        (ImportActionsResult {forLens, forResolve}, pm) <-
+          runIdeActionE "ImportActions" (shakeExtras state) $ useWithStaleFastE ImportActions nfp
         let inlayHints = [ inlayHint
                          | (range, (int, _)) <- forLens
                          , Just newRange <- [toCurrentRange pm range]

plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs

@@ -92,6 +92,7 @@ import           Development.IDE.Graph                (RuleResult)
 import           Development.IDE.Graph.Classes        (Hashable, NFData)
 import           Development.IDE.Spans.Pragmas        (NextPragmaInfo (..),
                                                        getFirstPragma,
+                                                       getFirstPragmaFast,
                                                        insertNewPragma)
 import           GHC.Generics                         (Generic)
 import           GHC.Iface.Ext.Types                  (Identifier)
@@ -225,31 +226,36 @@ codeActionResolveProvider ideState pId ca uri uid = do
     mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing
 
 inlayHintDotdotProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint
-inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
+inlayHintDotdotProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do
   nfp <- getNormalizedFilePathE uri
-  pragma <- getFirstPragma pId state nfp
   runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do
-    (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp
+    (pragmaInfo, pragmaPM) <- getFirstPragmaFast nfp
+    (crr@CRR {crCodeActions, crCodeActionResolve}, recordPM) <- useWithStaleFastE CollectRecords nfp
     let -- Get all records with dotdot in current nfp
         records = [ record
-                  | Just range <- [toCurrentRange pm visibleRange]
+                  | Just range <- [toCurrentRange recordPM visibleRange]
                   , uid <- RangeMap.elementsInRange range crCodeActions
                   , Just record <- [IntMap.lookup uid crCodeActionResolve] ]
         -- Get the definition of each dotdot of record
         locations = [ fmap (,record) (getDefinition nfp pos)
                     | record <- records
                     , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ]
     defnLocsList <- lift $ sequence locations
-    pure $ InL $ mapMaybe (mkInlayHint crr pragma pm) defnLocsList
+    pure $ InL $ mapMaybe (mkInlayHint crr pragmaInfo pragmaPM recordPM) defnLocsList
    where
-     mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> PositionMapping -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
-     mkInlayHint CRR {enabledExtensions, nameMap} pragma pm (defnLocs, record) =
+     mapTextEditRange :: PositionMapping -> TextEdit -> Maybe TextEdit
+     mapTextEditRange pm (TextEdit r t) = (\r' -> TextEdit r' t) <$> toCurrentRange pm r
+     -- Two separate position mappings are required because 'GetFileContents' and
+     -- 'CollectRecords' can be at different stale generations: 'CollectRecords'
+     -- depends on 'TypeCheck', which is further downstream than 'GetFileContents'.
+     mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> PositionMapping -> PositionMapping -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint
+     mkInlayHint CRR {enabledExtensions, nameMap} pragma pragmaPM recordPM (defnLocs, record) =
        let range = recordInfoToDotDotRange record
-           textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record)
-                    <> maybeToList (pragmaEdit enabledExtensions pragma)
+           textEdits = mapMaybe (mapTextEditRange recordPM) (maybeToList (renderRecordInfoAsTextEdit nameMap record))
+             <> mapMaybe (mapTextEditRange pragmaPM) (maybeToList (pragmaEdit enabledExtensions pragma))
            names = renderRecordInfoAsDotdotLabelName record
        in do
-         currentEnd <- range >>= toCurrentPosition pm . _end
+         currentEnd <- range >>= toCurrentPosition recordPM . _end
          names' <- names
          defnLocs' <- defnLocs
          let excludeDotDot (Location _ (Range _ end)) = end /= currentEnd
@@ -691,4 +697,3 @@ getRecPatterns _ = ([], False)
 
 printFieldName :: Outputable a => a -> Text
 printFieldName = stripOccNamePrefix . printOutputable
-