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.

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
 

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
 

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
-
-