Prevent Tactics hover provider from blocking at startup

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