diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5670cb540b..692bee21bb 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -956,14 +956,26 @@ defineEarlyCutoff :: IdeRule k v => RuleBody k v -> Rules () -defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' True (==) key file old mode $ op key file -defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' False (==) key file old mode $ second (mempty,) <$> op key file +defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + extras <- getShakeExtras + let diagnostics diags = do + traceDiagnostics diags + updateFileDiagnostics file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key file old mode $ op key file +defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + ShakeExtras{logger} <- getShakeExtras + let diagnostics diags = do + traceDiagnostics diags + mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags + defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file defineEarlyCutoff RuleWithCustomNewnessCheck{..} = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> - otTracedAction key file mode traceA $ - defineEarlyCutoff' False newnessCheck key file old mode $ + otTracedAction key file mode traceA $ \ traceDiagnostics -> do + ShakeExtras{logger} <- getShakeExtras + let diagnostics diags = do + mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags + traceDiagnostics diags + defineEarlyCutoff' diagnostics newnessCheck key file old mode $ second (mempty,) <$> build key file defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () @@ -978,7 +990,7 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> d defineEarlyCutoff' :: IdeRule k v - => Bool -- ^ update diagnostics + => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k @@ -988,7 +1000,7 @@ defineEarlyCutoff' -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file old mode action = do - extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras + ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of @@ -998,8 +1010,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do -- No changes in the dependencies and we have -- an existing successful result. Just (v@Succeeded{}, diags) -> do - when doDiagnostics $ - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags + doDiagnostics $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> @@ -1028,9 +1039,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) liftIO $ setValues state key file res (Vector.fromList diags) - if doDiagnostics - then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d] + doDiagnostics diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b (ShakeStale a, Just (ShakeStale b)) -> cmp a b diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index e3c8ee3895..b00f4d7931 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -45,6 +45,7 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionIO (GhcSessionIO)) import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule +import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) import Development.IDE.Types.Logger (Logger (Logger), logDebug, logInfo) @@ -128,7 +129,7 @@ otTracedAction -> NormalizedFilePath -- ^ Path to the file the action was run for -> RunMode -> (a -> String) - -> Action (RunResult a) -- ^ The action + -> (([FileDiagnostic] -> Action ()) -> Action (RunResult a)) -- ^ The action -> Action (RunResult a) otTracedAction key file mode result act | userTracingEnabled = fst <$> @@ -148,8 +149,8 @@ otTracedAction key file mode result act setTag sp "changed" $ case res of RunResult x _ _ -> fromString $ show x endSpan sp) - (const act) - | otherwise = act + (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) + | otherwise = act (\_ -> return ()) otTracedGarbageCollection label act | userTracingEnabled = fst <$> @@ -296,3 +297,4 @@ repeatUntilJust nattempts action = do case res of Nothing -> repeatUntilJust (nattempts-1) action Just{} -> return res + diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 9a008885a0..3081457cc2 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -177,7 +177,10 @@ runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurren argsDefaultHlsConfig = conf, argsLogger = logger, argsIdeOptions = \config sessionLoader -> - let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} + let ideOptions = (argsIdeOptions def config sessionLoader) + {optTesting = IdeTesting True + ,optCheckProject = pure False + } in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing) } diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 1d0b2783a9..9c44535530 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -64,7 +64,6 @@ tests = testGroup "splice" goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTest fp tc line col = goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do - _ <- waitForDiagnostics -- wait for the entire build to finish, so that code actions that -- use stale data will get uptodate stuff void waitForBuildQueue diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 547007e09c..98dfea147b 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -162,7 +162,7 @@ mkNoCodeLensTest input = resetGlobalHoleRef runSessionForTactics $ do doc <- openDoc (input <.> "hs") "haskell" - _ <- waitForDiagnostics + _ <- waitForBuildQueue lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc liftIO $ lenses `shouldBe` []