Speedup waitfordiagnosticsfrom

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

@@ -73,7 +73,8 @@ module Development.IDE.Core.Shake(
     garbageCollectDirtyKeysOlderThan,
     Log(..),
     VFSModified(..), getClientConfigAction,
-    ThreadQueue(..)
+    ThreadQueue(..),
+    runWithSignal
     ) where
 
 import           Control.Concurrent.Async
@@ -123,6 +124,10 @@ import           Development.IDE.Core.FileUtils         (getModTime)
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
+import           Development.IDE.Types.Options          as Options
+import qualified Language.LSP.Protocol.Message          as LSP
+import qualified Language.LSP.Server                    as LSP
+
 import           Development.IDE.Core.Tracing
 import           Development.IDE.Core.WorkerThread
 import           Development.IDE.GHC.Compat             (NameCache,
@@ -147,11 +152,11 @@ import qualified Development.IDE.Types.Exports          as ExportsMap
 import           Development.IDE.Types.KnownTargets
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Monitoring       (Monitoring (..))
-import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake
 import qualified Focus
 import           GHC.Fingerprint
 import           GHC.Stack                              (HasCallStack)
+import           GHC.TypeLits                           (KnownSymbol)
 import           HieDb.Types
 import           Ide.Logger                             hiding (Priority)
 import qualified Ide.Logger                             as Logger
@@ -165,7 +170,6 @@ import qualified Language.LSP.Protocol.Lens             as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import qualified Language.LSP.Protocol.Types            as LSP
-import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.VFS                       hiding (start)
 import qualified "list-t" ListT
 import           OpenTelemetry.Eventlog                 hiding (addEvent)
@@ -1350,29 +1354,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
 
 
@@ -1444,3 +1447,19 @@ updatePositionMappingHelper ver changes mappingForUri = snd $
         EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))
             zeroMapping
             (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)
+
+-- | sends a signal whenever shake session is run/restarted
+-- being used in cabal and hlint plugin tests to know when its time
+-- to look for file diagnostics
+kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action ()
+kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $
+  LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
+  toJSON $ map fromNormalizedFilePath files
+
+-- | Add kick start/done signal to rule
+runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action ()
+runWithSignal msgStart msgEnd files rule = do
+  ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras
+  kickSignal testing lspEnv files msgStart
+  void $ uses rule files
+  kickSignal testing lspEnv files msgEnd

haskell-language-server.cabal

@@ -714,7 +714,6 @@ library hls-hlint-plugin
     , hlint                 >= 3.5 && < 3.9
     , hls-plugin-api        == 2.9.0.1
     , lens
-    , lsp
     , mtl
     , refact
     , regex-tdfa
@@ -725,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

@@ -229,7 +229,7 @@ function invocation.
 kick :: Action ()
 kick = do
   files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
-  void $ uses Types.ParseCabalFile files
+  Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile
 
 -- ----------------------------------------------------------------
 -- Code Actions

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

@@ -83,6 +83,7 @@ codeActionUnitTests =
   where
     maxCompletions = 100
 
+
 -- ------------------------ ------------------------------------------------
 -- Integration Tests
 -- ------------------------------------------------------------------------
@@ -94,23 +95,23 @@ pluginTests =
         [ testGroup
             "Diagnostics"
             [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do
-                doc <- openDoc "invalid.cabal" "cabal"
-                diags <- waitForDiagnosticsFromSource doc "cabal"
+                _ <- openDoc "invalid.cabal" "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 <- 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 <- cabalCaptureKick
                 liftIO $ newDiags @?= []
             , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do
                 hsDoc <- openDoc "A.hs" "haskell"

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
@@ -52,6 +55,18 @@ runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin t
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-cabal-plugin" </> "test" </> "testdata"
 
+-- | these functions are used to detect cabal kicks
+-- and look at diagnostics for cabal files
+-- kicks are run everytime there is a shake session run/restart
+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

@@ -29,7 +29,6 @@ import           Control.Concurrent.STM
 import           Control.DeepSeq
 import           Control.Exception
 import           Control.Lens                                       ((?~), (^.))
-import           Control.Monad
 import           Control.Monad.Error.Class                          (MonadError (throwError))
 import           Control.Monad.IO.Class                             (MonadIO (liftIO))
 import           Control.Monad.Trans.Class                          (MonadTrans (lift))
@@ -119,6 +118,7 @@ import           System.Environment                                 (setEnv,
 #endif
 import           Development.IDE.Core.PluginUtils                   as PluginUtils
 import           Text.Regex.TDFA.Text                               ()
+
 -- ---------------------------------------------------------------------
 
 data Log
@@ -134,7 +134,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 +183,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 +202,8 @@ rules recorder plugin = do
     liftIO $ argsSettings flags
 
   action $ do
-    files <- getFilesOfInterestUntracked
-    void $ uses GetHlintDiagnostics $ Map.keys files
+    files <- Map.keys <$> getFilesOfInterestUntracked
+    Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics
 
   where