From 91dab7fa68b2ff3256b685b232932bbd41ae17af Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 26 Oct 2021 21:15:42 +0100 Subject: [PATCH] Prevent Tactics hover provider from blocking at startup 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 ba3bba4378..db6e6e02c9 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 d607aeb96a..8e6319d806 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 1cdee0b02d..096ccc0b79 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 - -