Using captureKicksDiagnostics to speed up multiple plugin tests

ghcide/src/Development/IDE/Core/OfInterest.hs

@@ -29,6 +29,7 @@ import           Development.IDE.Graph
 import           Control.Concurrent.STM.Stats             (atomically,
                                                            modifyTVar')
 import           Data.Aeson                               (toJSON)
+import qualified Data.Aeson                               as Aeson
 import qualified Data.ByteString                          as BS
 import           Data.Maybe                               (catMaybes)
 import           Development.IDE.Core.ProgressReporting

ghcide/src/Development/IDE/Core/Shake.hs

@@ -1350,29 +1350,28 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         let uri' = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do
-             join $ mask_ $ do
-                 lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
-                 let action = when (lastPublish /= newDiags) $ case lspEnv of
+            join $ mask_ $ do
+                lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
+                let action = when (lastPublish /= newDiags) $ case lspEnv of
                         Nothing -> -- Print an LSP event.
                             logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)
                         Just env -> LSP.runLspT env $ do
                             liftIO $ tag "count" (show $ Prelude.length newDiags)
                             liftIO $ tag "key" (show k)
                             LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $
                                 LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags
-                 return action
+                return action
     where
         diagsFromRule :: Diagnostic -> Diagnostic
         diagsFromRule c@Diagnostic{_range}
             | coerce ideTesting = c & L.relatedInformation ?~
-                         [
-                        DiagnosticRelatedInformation
+                        [ DiagnosticRelatedInformation
                             (Location
                                 (filePathToUri $ fromNormalizedFilePath fp)
                                 _range
                             )
                             (T.pack $ show k)
-                            ]
+                        ]
             | otherwise = c
 
 

haskell-language-server.cabal

@@ -248,6 +248,7 @@ library hls-cabal-plugin
 
 
   build-depends:
+    , aeson
     , base                  >=4.12     && <5
     , bytestring
     , Cabal-syntax          >= 3.7
@@ -723,6 +724,8 @@ library hls-hlint-plugin
     , unordered-containers
     , ghc-lib-parser-ex
     , apply-refact
+    --
+    , lsp-types
 
   if flag(ghc-lib)
     cpp-options:   -DGHC_LIB

hls-test-utils/src/Test/Hls.hs

@@ -61,14 +61,17 @@ module Test.Hls
     WithPriority(..),
     Recorder,
     Priority(..),
-    TestConfig(..),
+    captureKickDiagnostics,
+    kick,
+    TestConfig(..)
     )
 where
 
 import           Control.Applicative.Combinators
 import           Control.Concurrent.Async                 (async, cancel, wait)
 import           Control.Concurrent.Extra
 import           Control.Exception.Safe
+import           Control.Lens                             ((^.))
 import           Control.Lens.Extras                      (is)
 import           Control.Monad                            (guard, unless, void)
 import           Control.Monad.Extra                      (forM)
@@ -80,7 +83,7 @@ import qualified Data.Aeson                               as A
 import           Data.ByteString.Lazy                     (ByteString)
 import           Data.Default                             (Default, def)
 import qualified Data.Map                                 as M
-import           Data.Maybe                               (fromMaybe)
+import           Data.Maybe                               (fromMaybe, mapMaybe)
 import           Data.Proxy                               (Proxy (Proxy))
 import qualified Data.Text                                as T
 import qualified Data.Text.Lazy                           as TL
@@ -114,6 +117,7 @@ import           Ide.PluginUtils                          (idePluginsToPluginDes
                                                            pluginDescToIdePlugins)
 import           Ide.Types
 import           Language.LSP.Protocol.Capabilities
+import qualified Language.LSP.Protocol.Lens               as L
 import           Language.LSP.Protocol.Message
 import qualified Language.LSP.Protocol.Message            as LSP
 import           Language.LSP.Protocol.Types              hiding (Null)
@@ -231,14 +235,14 @@ goldenWithTestConfig
   :: Pretty b
   => TestConfig b
   -> TestName
-  -> FilePath
+  -> VirtualFileTree
   -> FilePath
   -> FilePath
   -> FilePath
   -> (TextDocumentIdentifier -> Session ())
   -> TestTree
-goldenWithTestConfig config title testDataDir path desc ext act =
-  goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
+goldenWithTestConfig config title tree path desc ext act =
+  goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
   $ runSessionWithTestConfig config $ const
   $ TL.encodeUtf8 . TL.fromStrict
   <$> do
@@ -869,6 +873,17 @@ setHlsConfig config = do
   -- requests!
   skipManyTill anyMessage (void configurationRequest)
 
+captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic]
+captureKickDiagnostics start done = do
+    _ <- skipManyTill anyMessage start
+    messages <- manyTill anyMessage done
+    pure $ concat $ mapMaybe diagnostics messages
+    where
+        diagnostics :: FromServerMessage' a -> Maybe [Diagnostic]
+        diagnostics = \msg -> case msg of
+            FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics)
+            _ -> Nothing
+
 waitForKickDone :: Session ()
 waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone
 
@@ -881,9 +896,11 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null
 nonTrivialKickStart :: Session ()
 nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null
 
+
 kick :: KnownSymbol k => Proxy k -> Session [FilePath]
 kick proxyMsg = do
   NotMess TNotificationMessage{_params} <- customNotification proxyMsg
   case fromJSON _params of
     Success x -> return x
     other     -> error $ "Failed to parse kick/done details: " <> show other
+

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -13,6 +13,7 @@ import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe                   (runMaybeT)
+import           Data.Aeson.Types                            (ToJSON (..))
 import qualified Data.ByteString                             as BS
 import           Data.Hashable
 import           Data.HashMap.Strict                         (HashMap)
@@ -27,10 +28,12 @@ import qualified Development.IDE.Core.Shake                  as Shake
 import           Development.IDE.Graph                       (Key, alwaysRerun)
 import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
 import qualified Development.IDE.Plugin.Completions.Types    as Ghcide
+import qualified Development.IDE.Types.Options               as Options
 import           Development.IDE.Types.Shake                 (toKey)
 import qualified Distribution.Fields                         as Syntax
 import qualified Distribution.Parsec.Position                as Syntax
 import           GHC.Generics
+import           GHC.TypeLits                                (KnownSymbol)
 import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
 import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
 import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalCommonSections (ParseCabalCommonSections),
@@ -45,6 +48,7 @@ import           Ide.Types
 import qualified Language.LSP.Protocol.Lens                  as JL
 import qualified Language.LSP.Protocol.Message               as LSP
 import           Language.LSP.Protocol.Types
+import qualified Language.LSP.Server                         as LSP
 import qualified Language.LSP.VFS                            as VFS
 
 data Log
@@ -227,7 +231,14 @@ function invocation.
 kick :: Action ()
 kick = do
   files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
+  Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras
+  let signal :: KnownSymbol s => Proxy s -> Action ()
+      signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $
+        LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
+        toJSON $ map fromNormalizedFilePath files
+  signal (Proxy @"kick/start/cabal")
   void $ uses Types.ParseCabalFile files
+  signal(Proxy @"kick/done/cabal")
 
 -- ----------------------------------------------------------------
 -- Code Actions

plugins/hls-cabal-plugin/test/Main.hs

@@ -79,6 +79,7 @@ codeActionUnitTests =
   where
     maxCompletions = 100
 
+
 -- ------------------------ ------------------------------------------------
 -- Integration Tests
 -- ------------------------------------------------------------------------
@@ -90,23 +91,26 @@ pluginTests =
         [ testGroup
             "Diagnostics"
             [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do
-                doc <- openDoc "invalid.cabal" "cabal"
-                diags <- waitForDiagnosticsFromSource doc "cabal"
+                _ <- openDoc "invalid.cabal" "cabal"
+                -- diags <- waitForDiagnosticsFromSource doc "cabal"
+                diags <- cabalCaptureKick
                 unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
                 liftIO $ do
                     length diags @?= 1
                     unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
                     unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
             , runCabalTestCaseSession "Clears diagnostics" "" $ do
                 doc <- openDoc "invalid.cabal" "cabal"
-                diags <- waitForDiagnosticsFrom doc
+                -- diags <- waitForDiagnosticsFrom doc
+                diags <- cabalCaptureKick
                 unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
                 liftIO $ do
                     length diags @?= 1
                     unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
                     unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
                 _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n"
-                newDiags <- waitForDiagnosticsFrom doc
+                -- newDiags <- waitForDiagnosticsFrom doc
+                newDiags <- cabalCaptureKick
                 liftIO $ newDiags @?= []
             , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do
                 hsDoc <- openDoc "A.hs" "haskell"
@@ -141,7 +145,8 @@ pluginTests =
             "Code Actions"
             [ runCabalTestCaseSession "BSD-3" "" $ do
                 doc <- openDoc "licenseCodeAction.cabal" "cabal"
-                diags <- waitForDiagnosticsFromSource doc "cabal"
+                -- diags <- waitForDiagnosticsFromSource doc "cabal"
+                diags <- cabalCaptureKick
                 reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
                 liftIO $ do
                     length diags @?= 1
@@ -164,7 +169,8 @@ pluginTests =
                             ]
             , runCabalTestCaseSession "Apache-2.0" "" $ do
                 doc <- openDoc "licenseCodeAction2.cabal" "cabal"
-                diags <- waitForDiagnosticsFromSource doc "cabal"
+                -- diags <- waitForDiagnosticsFromSource doc "cabal"
+                diags <- cabalCaptureKick
                 -- test if it supports typos in license name, here 'apahe'
                 reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"]
                 liftIO $ do

plugins/hls-cabal-plugin/test/Utils.hs

@@ -1,9 +1,12 @@
+{-# LANGUAGE DataKinds                #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE OverloadedStrings        #-}
 
 module Utils where
 
+import           Control.Monad                     (guard)
 import           Data.List                         (sort)
+import           Data.Proxy                        (Proxy (Proxy))
 import qualified Data.Text                         as T
 import           Ide.Plugin.Cabal                  (descriptor)
 import qualified Ide.Plugin.Cabal
@@ -49,6 +52,15 @@ runCabalSession subdir =
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-cabal-plugin" </> "test" </> "testdata"
 
+cabalKickDone :: Session ()
+cabalKickDone = kick (Proxy @"kick/done/cabal") >>= guard . not . null
+
+cabalKickStart :: Session ()
+cabalKickStart = kick (Proxy @"kick/start/cabal") >>= guard . not . null
+
+cabalCaptureKick :: Session [Diagnostic]
+cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone
+
 -- | list comparison where the order in the list is irrelevant
 (@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion
 (@?==) l1 l2 = sort l1 @?= sort l2

plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -118,7 +118,12 @@ import           System.Environment                                 (setEnv,
                                                                      unsetEnv)
 #endif
 import           Development.IDE.Core.PluginUtils                   as PluginUtils
+import qualified Development.IDE.Types.Options                      as Options
+import           GHC.TypeLits                                       (KnownSymbol)
+import qualified Language.LSP.Protocol.Message                      as LSP
+import qualified Language.LSP.Server                                as LSP
 import           Text.Regex.TDFA.Text                               ()
+
 -- ---------------------------------------------------------------------
 
 data Log
@@ -134,7 +139,7 @@ instance Pretty Log where
     LogShake log -> pretty log
     LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res
     LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas
-    LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts
+    LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts)
     LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
     LogResolve msg -> pretty msg
 
@@ -183,12 +188,12 @@ instance NFData   GetHlintDiagnostics
 type instance RuleResult GetHlintDiagnostics = ()
 
 -- | Hlint rules to generate file diagnostics based on hlint hints
--- | This rule is recomputed when:
--- | - A file has been edited via
--- |    - `getIdeas` -> `getParsedModule` in any case
--- |    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
--- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
--- | - The hlint specific settings have changed, via `getHlintSettingsRule`
+-- This rule is recomputed when:
+-- - A file has been edited via
+--    - `getIdeas` -> `getParsedModule` in any case
+--    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
+-- - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
+-- - The hlint specific settings have changed, via `getHlintSettingsRule`
 rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
 rules recorder plugin = do
   define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do
@@ -202,8 +207,16 @@ rules recorder plugin = do
     liftIO $ argsSettings flags
 
   action $ do
-    files <- getFilesOfInterestUntracked
-    void $ uses GetHlintDiagnostics $ Map.keys files
+    files <- Map.keys <$> getFilesOfInterestUntracked
+    Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras
+    let signal :: KnownSymbol s => Proxy s -> Action ()
+        signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $
+            LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
+            toJSON $ map fromNormalizedFilePath files
+
+    signal (Proxy @"kick/start/hlint")
+    void $ uses GetHlintDiagnostics files
+    signal (Proxy @"kick/done/hlint")
 
   where