WIP: Speed up hls-hlint-plugin-tests

Move test data to temporary directory.
Avoid `waitForDiagnosticsWithSource` as it unconditionally waits for
diagnostics.

Author: fendor

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

@@ -48,6 +48,7 @@ import           Ide.Logger                               (Pretty (pretty),
                                                            logDebug)
 import qualified Language.LSP.Protocol.Message            as LSP
 import qualified Language.LSP.Server                      as LSP
+import qualified Data.Aeson as Aeson
 
 data Log = LogShake Shake.Log
   deriving Show

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

@@ -1281,29 +1281,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

@@ -691,6 +691,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

@@ -4,6 +4,7 @@
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedLists       #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE OverloadedStrings     #-}
 module Test.Hls
   ( module Test.Tasty.HUnit,
     module Test.Tasty,
@@ -57,6 +58,7 @@ module Test.Hls
     WithPriority(..),
     Recorder,
     Priority(..),
+    captureKickDiagnostics,
     )
 where
 
@@ -124,6 +126,9 @@ import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.Golden
 import           Test.Tasty.HUnit
 import           Test.Tasty.Ingredients.Rerun
+import Language.LSP.Protocol.Lens qualified as L
+import Data.Maybe (mapMaybe)
+import Control.Lens ((^.))
 
 data Log
   = LogIDEMain IDEMain.Log
@@ -712,6 +717,17 @@ setHlsConfig config = do
   -- requests!
   skipManyTill anyMessage (void configurationRequest)
 
+captureKickDiagnostics :: Session [Diagnostic]
+captureKickDiagnostics = do
+    _ <- skipManyTill anyMessage nonTrivialKickStart2
+    messages <- manyTill anyMessage nonTrivialKickDone2
+    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
 
@@ -724,9 +740,17 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null
 nonTrivialKickStart :: Session ()
 nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null
 
+nonTrivialKickDone2 :: Session ()
+nonTrivialKickDone2 = kick (Proxy @"kick/done/hlint") >>= guard . not . null
+
+nonTrivialKickStart2 :: Session ()
+nonTrivialKickStart2 = kick (Proxy @"kick/start/hlint") >>= 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-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -125,6 +125,11 @@ import           System.Environment                                 (setEnv,
 #endif
 import           Development.IDE.Core.PluginUtils                   as PluginUtils
 import           Text.Regex.TDFA.Text                               ()
+import qualified Language.LSP.Protocol.Message            as LSP
+import qualified Language.LSP.Server                      as LSP
+import GHC.TypeLits (KnownSymbol)
+import qualified Development.IDE.Types.Options as Options
+
 -- ---------------------------------------------------------------------
 
 data Log
@@ -140,7 +145,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
 
@@ -189,12 +194,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
@@ -208,8 +213,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