From f8cee6a6c893052fa6ba46575f0a5a05c21e9de6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Nov 2021 12:27:51 +0000 Subject: [PATCH 1/6] trace rule diagnostics --- ghcide/src/Development/IDE/Core/Shake.hs | 35 ++++--- ghcide/src/Development/IDE/Core/Tracing.hs | 112 +++++++++++---------- 2 files changed, 80 insertions(+), 67 deletions(-) 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..866a207bb9 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -16,62 +16,65 @@ module Development.IDE.Core.Tracing ) where -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (Var, modifyVar_, newVar, - readVar, threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (SomeException, catch, - generalBracket) -import Control.Monad (forM_, forever, void, when, - (>=>)) -import Control.Monad.Catch (ExitCase (..), MonadMask) -import Control.Monad.Extra (whenJust) +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (Var, modifyVar_, newVar, + readVar, threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (SomeException, catch, + generalBracket) +import Control.Monad (forM_, forever, void, when, + (>=>)) +import Control.Monad.Catch (ExitCase (..), MonadMask) +import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift -import Control.Seq (r0, seqList, seqTuple2, using) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (TypeRep, typeOf) -import Data.Word (Word16) -import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) -import Development.IDE.Graph (Action) +import Control.Seq (r0, seqList, seqTuple2, + using) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Dynamic (Dynamic) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) +import Data.Word (Word16) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + GhcSessionIO (GhcSessionIO)) +import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule -import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger), logDebug, - logInfo) -import Development.IDE.Types.Shake (Value, - ValueWithDiagnostics (..), - Values, fromKeyType) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Ide.PluginUtils (installSigUsr1Handler) -import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, - fromNormalizedFilePath) -import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, - beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) - -#if MIN_VERSION_ghc(8,8,0) +import Development.IDE.Types.Diagnostics (FileDiagnostic, + showDiagnostics) +import Development.IDE.Types.Location (Uri (..)) +import Development.IDE.Types.Logger (Logger (Logger), logDebug, + logInfo) +import Development.IDE.Types.Shake (Value, + ValueWithDiagnostics (..), + Values, fromKeyType) +import Foreign.Storable (Storable (sizeOf)) +import HeapSize (recursiveSize, runHeapsize) +import Ide.PluginUtils (installSigUsr1Handler) +import Ide.Types (PluginId (..)) +import Language.LSP.Types (NormalizedFilePath, + fromNormalizedFilePath) +import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, + mkValueObserver, observe, + setTag, withSpan, withSpan_) + + otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a -#endif + + + + + withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a @@ -128,7 +131,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 +151,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 +299,4 @@ repeatUntilJust nattempts action = do case res of Nothing -> repeatUntilJust (nattempts-1) action Just{} -> return res + From db4b64ede6a5ea5712abcc8193805b884bf14be7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Nov 2021 12:43:51 +0000 Subject: [PATCH 2/6] disable checkProject in HLS test suite We already disable this in ghcide tests It introduces noise (traces are harder to read), and can potentially break tests too (e.g. eval plugin) --- hls-test-utils/src/Test/Hls.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 9d4014a7e5..0732664ebc 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -54,7 +54,8 @@ import Development.IDE.Plugin.Test (TestRequest (GetLastBuildKeys, import Development.IDE.Types.Options import GHC.IO.Handle import Ide.Plugin.Config (Config, formattingProvider) -import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Test import Language.LSP.Types hiding @@ -176,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) } @@ -233,7 +237,7 @@ callTestPlugin cmd = do return $ do e <- _result case A.fromJSON e of - A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing + A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing A.Success a -> pure a waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) From b416577f1cfc1c5663e2c4667dd2fed2d9889810 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Nov 2021 12:55:50 +0000 Subject: [PATCH 3/6] Undo breaking auto-format --- ghcide/src/Development/IDE/Core/Tracing.hs | 105 ++++++++++----------- 1 file changed, 51 insertions(+), 54 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 866a207bb9..498386d193 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -16,65 +16,62 @@ module Development.IDE.Core.Tracing ) where -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (Var, modifyVar_, newVar, - readVar, threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (SomeException, catch, - generalBracket) -import Control.Monad (forM_, forever, void, when, - (>=>)) -import Control.Monad.Catch (ExitCase (..), MonadMask) -import Control.Monad.Extra (whenJust) +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (Var, modifyVar_, newVar, + readVar, threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (SomeException, catch, + generalBracket) +import Control.Monad (forM_, forever, void, when, + (>=>)) +import Control.Monad.Catch (ExitCase (..), MonadMask) +import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift -import Control.Seq (r0, seqList, seqTuple2, - using) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (TypeRep, typeOf) -import Data.Word (Word16) -import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) -import Development.IDE.Graph (Action) +import Control.Seq (r0, seqList, seqTuple2, using) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Dynamic (Dynamic) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) +import Data.Word (Word16) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + 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) -import Development.IDE.Types.Shake (Value, - ValueWithDiagnostics (..), - Values, fromKeyType) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Ide.PluginUtils (installSigUsr1Handler) -import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, - fromNormalizedFilePath) -import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, - beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) - - +import Development.IDE.Types.Location (Uri (..)) +import Development.IDE.Types.Logger (Logger (Logger), logDebug, + logInfo) +import Development.IDE.Types.Shake (Value, + ValueWithDiagnostics (..), + Values, fromKeyType) +import Foreign.Storable (Storable (sizeOf)) +import HeapSize (recursiveSize, runHeapsize) +import Ide.PluginUtils (installSigUsr1Handler) +import Ide.Types (PluginId (..)) +import Language.LSP.Types (NormalizedFilePath, + fromNormalizedFilePath) +import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, + mkValueObserver, observe, + setTag, withSpan, withSpan_) + +#if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a - - - - - +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a +#endif withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a From fec7e9623b984a09c903081d4b0a2ad6b517c3fd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Nov 2021 13:02:52 +0000 Subject: [PATCH 4/6] fix missing import --- ghcide/src/Development/IDE/Core/Tracing.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 498386d193..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) From 6264f5abccf644950f46de8a9dfc8ed40cf8f46a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Nov 2021 23:50:00 +0000 Subject: [PATCH 5/6] Fix splice plugin tests --- plugins/hls-splice-plugin/test/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 23c187846c..37b807fea9 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 From a14bd9218bb43f56bb8ee75e1e31a0a3a04f2f11 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 9 Nov 2021 16:19:02 +0000 Subject: [PATCH 6/6] Fix test --- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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` []