Trace diagnostics (#2333)

pepeiborra · jneira · web-flow · commit 9415e55672a0 · 2021-11-10T15:01:30.000Z
* trace rule diagnostics

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

* Undo breaking auto-format

* fix missing import

* Fix splice plugin tests

* Fix test

Co-authored-by: Javier Neira &lt;atreyu.bbb@gmail.com&gt;
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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` []
 
