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