From ce1f353be354711d905f287d1b22f24c06606409 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 31 Oct 2021 19:19:19 +0000
Subject: [PATCH] Prevent Tactics hover provider from blocking at startup
(#2306)
There's been a lot of work done on making hover and getDefinition immediately responsive at startup by using persisted data.
Unfortunately we didn't install tests to preserve this fragile property. We should add those tests to the func-test testsuite.
The problem here is that Tactics installs a hover handler that depends on the TypeCheck rule. Since there is no persistent provider for this rule, it blocks until the file can be typechecked. Since HLS does not implement partial responses (and neither do most LSP clients anyway), this blocks all the other hover providers.
The solution is to install a new build rule GetMetaprograms that depends on TypeCheck, install a persistent provider for it that returns the empty list of meta programs, and switch the hover provider to useWithStaleFast.
The downsides of doing this are negligible - the hover provider won't show any metaprogram specific info if used at startup, but it will work finely on a second attempt.
---
.../src/Wingman/Judgements/SYB.hs | 10 +++-
.../src/Wingman/LanguageServer.hs | 54 ++++++++++++++++---
.../src/Wingman/LanguageServer/Metaprogram.hs | 31 ++---------
3 files changed, 58 insertions(+), 37 deletions(-)
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs
index ba3bba43..db6e6e02 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs
@@ -85,8 +85,14 @@ sameTypeModuloLastApp =
_ -> False
-metaprogramQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]
-metaprogramQ ss = everythingContaining ss $ mkQ mempty $ \case
+metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]
+metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case
+ L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program)
+ (_ :: LHsExpr GhcTc) -> mempty
+
+
+metaprogramQ :: GenericQ [(SrcSpan, T.Text)]
+metaprogramQ = everything (<>) $ mkQ mempty $ \case
L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program)
(_ :: LHsExpr GhcTc) -> mempty
diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
index d607aeb9..8e6319d8 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
@@ -26,12 +26,12 @@ import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Traversable
-import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange)
-import Development.IDE (hscEnv)
+import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction)
+import Development.IDE.Core.PositionMapping (idDelta)
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Rules (usePropertyAction)
import Development.IDE.Core.Service (runAction)
-import Development.IDE.Core.Shake (IdeState (..), uses, define, use)
+import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule)
import qualified Development.IDE.Core.Shake as IDE
import Development.IDE.Core.UseStale
import Development.IDE.GHC.Compat hiding (empty)
@@ -47,8 +47,7 @@ import qualified Ide.Plugin.Config as Plugin
import Ide.Plugin.Properties
import Ide.PluginUtils (usePropertyLsp)
import Ide.Types (PluginId)
-import Language.Haskell.GHC.ExactPrint (Transform)
-import Language.Haskell.GHC.ExactPrint (modifyAnnsT, addAnnotationsForPretty)
+import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty)
import Language.LSP.Server (MonadLsp, sendNotification)
import Language.LSP.Types hiding
(SemanticTokenAbsolute (length, line),
@@ -60,7 +59,7 @@ import Retrie (transformA)
import Wingman.Context
import Wingman.GHC
import Wingman.Judgements
-import Wingman.Judgements.SYB (everythingContaining, metaprogramQ)
+import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ)
import Wingman.Judgements.Theta
import Wingman.Range
import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)
@@ -80,6 +79,9 @@ tcCommandName = T.pack . show
runIde :: String -> String -> IdeState -> Action a -> IO a
runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state
+runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a
+runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state)
+
runCurrentIde
:: forall a r
@@ -126,6 +128,21 @@ unsafeRunStaleIde herald state nfp a = do
(r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp
pure r
+unsafeRunStaleIdeFast
+ :: forall a r
+ . ( r ~ RuleResult a
+ , Eq a , Hashable a , Show a , Typeable a , NFData a
+ , Show r, Typeable r, NFData r
+ )
+ => String
+ -> IdeState
+ -> NormalizedFilePath
+ -> a
+ -> MaybeT IO r
+unsafeRunStaleIdeFast herald state nfp a = do
+ (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp
+ pure r
+
------------------------------------------------------------------------------
@@ -522,6 +539,14 @@ instance NFData WriteDiagnostics
type instance RuleResult WriteDiagnostics = ()
+data GetMetaprograms = GetMetaprograms
+ deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable GetMetaprograms
+instance NFData GetMetaprograms
+
+type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)]
+
wingmanRules :: PluginId -> Rules ()
wingmanRules plId = do
define $ \WriteDiagnostics nfp ->
@@ -553,6 +578,21 @@ wingmanRules plId = do
, Just ()
)
+ defineNoDiagnostics $ \GetMetaprograms nfp -> do
+ TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp
+ let scrutinees = traverse (metaprogramQ . tcg_binds) tcg
+ return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do
+ case ss of
+ RealSrcSpan r _ -> do
+ rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r
+ pure (rss', program)
+ UnhelpfulSpan _ -> Nothing
+
+ -- This persistent rule helps to avoid blocking HLS hover providers at startup
+ -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other
+ -- hover providers from being used to produce a response
+ addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing)
+
action $ do
files <- getFilesOfInterestUntracked
void $ uses WriteDiagnostics $ Map.keys files
@@ -607,7 +647,7 @@ getMetaprogramAtSpan
getMetaprogramAtSpan (unTrack -> ss)
= fmap snd
. listToMaybe
- . metaprogramQ ss
+ . metaprogramAtQ ss
. tcg_binds
. unTrack
diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs
index 1cdee0b0..096ccc0b 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs
@@ -15,18 +15,14 @@ import Control.Monad.Trans.Maybe
import Data.List (find)
import Data.Maybe
import qualified Data.Text as T
-import Data.Traversable
import Development.IDE (positionToRealSrcLoc)
import Development.IDE (realSrcSpanToRange)
-import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake (IdeState (..))
import Development.IDE.Core.UseStale
import Development.IDE.GHC.Compat hiding (empty)
import Ide.Types
import Language.LSP.Types
import Prelude hiding (span)
-import Wingman.GHC
-import Wingman.Judgements.SYB (metaprogramQ)
import Wingman.LanguageServer
import Wingman.Metaprogramming.Parser (attempt_it)
import Wingman.Types
@@ -38,13 +34,14 @@ hoverProvider :: PluginMethodHandler IdeState TextDocumentHover
hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos
+ stale = unsafeRunStaleIdeFast "hoverProvider" state nfp
cfg <- getTacticConfig plId
liftIO $ fromMaybeT (Right Nothing) $ do
- holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan (unTrack loc) Nothing
+ holes <- stale GetMetaprograms
fmap (Right . Just) $
- case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of
+ case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of
Just (trss, program) -> do
let tr_range = fmap realSrcSpanToRange trss
rsl = realSrcSpanStart $ unTrack trss
@@ -59,27 +56,5 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr
Nothing -> empty
hoverProvider _ _ _ = pure $ Right Nothing
-
fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT def = fmap (fromMaybe def) . runMaybeT
-
-
-getMetaprogramsAtSpan
- :: IdeState
- -> NormalizedFilePath
- -> SrcSpan
- -> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)]
-getMetaprogramsAtSpan state nfp ss = do
- let stale a = runStaleIde "getMetaprogramsAtSpan" state nfp a
-
- TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck
-
- let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg
- for scrutinees $ \aged@(unTrack -> (ss, program)) -> do
- case ss of
- RealSrcSpan r _ -> do
- rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
- pure (rss', program)
- UnhelpfulSpan _ -> empty
-
-
--
GitLab