Skip to content

Commit ce1f353

Browse files
pepeiborrapepeiborra
authored
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.
1 parent 2204a16 commit ce1f353

File tree

3 files changed

+58
-37
lines changed

3 files changed

+58
-37
lines changed

‎plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -85,8 +85,14 @@ sameTypeModuloLastApp =
8585
_ -> False
8686

8787

88-
metaprogramQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]
89-
metaprogramQ ss = everythingContaining ss $ mkQ mempty $ \case
88+
metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]
89+
metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case
90+
L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program)
91+
(_ :: LHsExpr GhcTc) -> mempty
92+
93+
94+
metaprogramQ :: GenericQ [(SrcSpan, T.Text)]
95+
metaprogramQ = everything (<>) $ mkQ mempty $ \case
9096
L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program)
9197
(_ :: LHsExpr GhcTc) -> mempty
9298

‎plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs

Lines changed: 47 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -26,12 +26,12 @@ import Data.Set (Set)
2626
import qualified Data.Set as S
2727
import qualified Data.Text as T
2828
import Data.Traversable
29-
import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange)
30-
import Development.IDE (hscEnv)
29+
import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction)
30+
import Development.IDE.Core.PositionMapping (idDelta)
3131
import Development.IDE.Core.RuleTypes
3232
import Development.IDE.Core.Rules (usePropertyAction)
3333
import Development.IDE.Core.Service (runAction)
34-
import Development.IDE.Core.Shake (IdeState (..), uses, define, use)
34+
import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule)
3535
import qualified Development.IDE.Core.Shake as IDE
3636
import Development.IDE.Core.UseStale
3737
import Development.IDE.GHC.Compat hiding (empty)
@@ -47,8 +47,7 @@ import qualified Ide.Plugin.Config as Plugin
4747
import Ide.Plugin.Properties
4848
import Ide.PluginUtils (usePropertyLsp)
4949
import Ide.Types (PluginId)
50-
import Language.Haskell.GHC.ExactPrint (Transform)
51-
import Language.Haskell.GHC.ExactPrint (modifyAnnsT, addAnnotationsForPretty)
50+
import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty)
5251
import Language.LSP.Server (MonadLsp, sendNotification)
5352
import Language.LSP.Types hiding
5453
(SemanticTokenAbsolute (length, line),
@@ -60,7 +59,7 @@ import Retrie (transformA)
6059
import Wingman.Context
6160
import Wingman.GHC
6261
import Wingman.Judgements
63-
import Wingman.Judgements.SYB (everythingContaining, metaprogramQ)
62+
import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ)
6463
import Wingman.Judgements.Theta
6564
import Wingman.Range
6665
import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)
@@ -80,6 +79,9 @@ tcCommandName = T.pack . show
8079
runIde :: String -> String -> IdeState -> Action a -> IO a
8180
runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state
8281

82+
runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a
83+
runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state)
84+
8385

8486
runCurrentIde
8587
:: forall a r
@@ -126,6 +128,21 @@ unsafeRunStaleIde herald state nfp a = do
126128
(r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp
127129
pure r
128130

131+
unsafeRunStaleIdeFast
132+
:: forall a r
133+
. ( r ~ RuleResult a
134+
, Eq a , Hashable a , Show a , Typeable a , NFData a
135+
, Show r, Typeable r, NFData r
136+
)
137+
=> String
138+
-> IdeState
139+
-> NormalizedFilePath
140+
-> a
141+
-> MaybeT IO r
142+
unsafeRunStaleIdeFast herald state nfp a = do
143+
(r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp
144+
pure r
145+
129146

130147
------------------------------------------------------------------------------
131148

@@ -522,6 +539,14 @@ instance NFData WriteDiagnostics
522539

523540
type instance RuleResult WriteDiagnostics = ()
524541

542+
data GetMetaprograms = GetMetaprograms
543+
deriving (Eq, Show, Typeable, Generic)
544+
545+
instance Hashable GetMetaprograms
546+
instance NFData GetMetaprograms
547+
548+
type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)]
549+
525550
wingmanRules :: PluginId -> Rules ()
526551
wingmanRules plId = do
527552
define $ \WriteDiagnostics nfp ->
@@ -553,6 +578,21 @@ wingmanRules plId = do
553578
, Just ()
554579
)
555580

581+
defineNoDiagnostics $ \GetMetaprograms nfp -> do
582+
TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp
583+
let scrutinees = traverse (metaprogramQ . tcg_binds) tcg
584+
return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do
585+
case ss of
586+
RealSrcSpan r _ -> do
587+
rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r
588+
pure (rss', program)
589+
UnhelpfulSpan _ -> Nothing
590+
591+
-- This persistent rule helps to avoid blocking HLS hover providers at startup
592+
-- Without it, the GetMetaprograms rule blocks on typecheck and prevents other
593+
-- hover providers from being used to produce a response
594+
addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing)
595+
556596
action $ do
557597
files <- getFilesOfInterestUntracked
558598
void $ uses WriteDiagnostics $ Map.keys files
@@ -607,7 +647,7 @@ getMetaprogramAtSpan
607647
getMetaprogramAtSpan (unTrack -> ss)
608648
= fmap snd
609649
. listToMaybe
610-
. metaprogramQ ss
650+
. metaprogramAtQ ss
611651
. tcg_binds
612652
. unTrack
613653

‎plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs

Lines changed: 3 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -15,18 +15,14 @@ import Control.Monad.Trans.Maybe
1515
import Data.List (find)
1616
import Data.Maybe
1717
import qualified Data.Text as T
18-
import Data.Traversable
1918
import Development.IDE (positionToRealSrcLoc)
2019
import Development.IDE (realSrcSpanToRange)
21-
import Development.IDE.Core.RuleTypes
2220
import Development.IDE.Core.Shake (IdeState (..))
2321
import Development.IDE.Core.UseStale
2422
import Development.IDE.GHC.Compat hiding (empty)
2523
import Ide.Types
2624
import Language.LSP.Types
2725
import Prelude hiding (span)
28-
import Wingman.GHC
29-
import Wingman.Judgements.SYB (metaprogramQ)
3026
import Wingman.LanguageServer
3127
import Wingman.Metaprogramming.Parser (attempt_it)
3228
import Wingman.Types
@@ -38,13 +34,14 @@ hoverProvider :: PluginMethodHandler IdeState TextDocumentHover
3834
hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)
3935
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
4036
let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos
37+
stale = unsafeRunStaleIdeFast "hoverProvider" state nfp
4138

4239
cfg <- getTacticConfig plId
4340
liftIO $ fromMaybeT (Right Nothing) $ do
44-
holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan (unTrack loc) Nothing
41+
holes <- stale GetMetaprograms
4542

4643
fmap (Right . Just) $
47-
case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of
44+
case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of
4845
Just (trss, program) -> do
4946
let tr_range = fmap realSrcSpanToRange trss
5047
rsl = realSrcSpanStart $ unTrack trss
@@ -59,27 +56,5 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr
5956
Nothing -> empty
6057
hoverProvider _ _ _ = pure $ Right Nothing
6158

62-
6359
fromMaybeT :: Functor m => a -> MaybeT m a -> m a
6460
fromMaybeT def = fmap (fromMaybe def) . runMaybeT
65-
66-
67-
getMetaprogramsAtSpan
68-
:: IdeState
69-
-> NormalizedFilePath
70-
-> SrcSpan
71-
-> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)]
72-
getMetaprogramsAtSpan state nfp ss = do
73-
let stale a = runStaleIde "getMetaprogramsAtSpan" state nfp a
74-
75-
TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck
76-
77-
let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg
78-
for scrutinees $ \aged@(unTrack -> (ss, program)) -> do
79-
case ss of
80-
RealSrcSpan r _ -> do
81-
rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
82-
pure (rss', program)
83-
UnhelpfulSpan _ -> empty
84-
85-

0 commit comments

Comments
 (0)