Introduce common code for Recorders in Plugin Tests

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

@@ -20,21 +20,35 @@ module Test.Hls
     goldenWithHaskellDocFormatter,
     goldenWithCabalDocFormatter,
     def,
+    -- * Running HLS for integration tests
     runSessionWithServer,
+    runSessionWithServerAndCaps,
     runSessionWithServerFormatter,
     runSessionWithCabalServerFormatter,
     runSessionWithServer',
-    waitForProgressDone,
-    waitForAllProgressDone,
+    -- * Helpful re-exports
     PluginDescriptor,
     IdeState,
+    -- * Assertion helper functions
+    waitForProgressDone,
+    waitForAllProgressDone,
     waitForBuildQueue,
     waitForTypecheck,
     waitForAction,
     sendConfigurationChanged,
     getLastBuildKeys,
     waitForKickDone,
     waitForKickStart,
+    -- * Plugin descriptor helper functions for tests
+    PluginTestDescriptor,
+    pluginTestRecorder,
+    mkPluginTestDescriptor,
+    mkPluginTestDescriptor',
+    -- * Re-export logger types
+    -- Avoids slightly annoying ghcide imports when they are unnecessary.
+    WithPriority(..),
+    Recorder,
+    Priority(..),
     )
 where
 
@@ -43,6 +57,7 @@ import           Control.Concurrent.Async        (async, cancel, wait)
 import           Control.Concurrent.Extra
 import           Control.Exception.Base
 import           Control.Monad                   (guard, unless, void)
+import           Control.Monad.Extra             (forM)
 import           Control.Monad.IO.Class
 import           Data.Aeson                      (Result (Success),
                                                   Value (Null), fromJSON,
@@ -62,7 +77,7 @@ import qualified Development.IDE.Main            as IDEMain
 import           Development.IDE.Plugin.Test     (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
                                                   WaitForIdeRuleResult (ideResultSuccess))
 import qualified Development.IDE.Plugin.Test     as Test
-import           Development.IDE.Types.Logger    (Logger (Logger),
+import           Development.IDE.Types.Logger    (Doc, Logger (Logger),
                                                   Pretty (pretty),
                                                   Priority (Debug),
                                                   Recorder (Recorder, logger_),
@@ -117,7 +132,8 @@ goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
 goldenGitDiff name = goldenVsStringDiff name gitDiff
 
 goldenWithHaskellDoc
-  :: PluginDescriptor IdeState
+  :: Pretty b
+  => PluginTestDescriptor b
   -> TestName
   -> FilePath
   -> FilePath
@@ -128,7 +144,8 @@ goldenWithHaskellDoc
 goldenWithHaskellDoc = goldenWithDoc "haskell"
 
 goldenWithCabalDoc
-  :: PluginDescriptor IdeState
+  :: Pretty b
+  => PluginTestDescriptor b
   -> TestName
   -> FilePath
   -> FilePath
@@ -139,8 +156,9 @@ goldenWithCabalDoc
 goldenWithCabalDoc = goldenWithDoc "cabal"
 
 goldenWithDoc
-  :: T.Text
-  -> PluginDescriptor IdeState
+  :: Pretty b
+  => T.Text
+  -> PluginTestDescriptor b
   -> TestName
   -> FilePath
   -> FilePath
@@ -158,23 +176,119 @@ goldenWithDoc fileType plugin title testDataDir path desc ext act =
     act doc
     documentContents doc
 
+-- ------------------------------------------------------------
+-- Helper function for initialising plugins under test
+-- ------------------------------------------------------------
+
+-- | Plugin under test where a fitting recorder is injected.
+type PluginTestDescriptor b = Recorder (WithPriority b) -> PluginDescriptor IdeState
+
+-- | Wrap a plugin you want to test, and inject a fitting recorder as required.
+--
+-- If you want to write the logs to stderr, run your tests with
+-- "HLS_TEST_PLUGIN_LOG_STDERR=1", e.g.
+--
+-- @
+--   HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test <test-suite-of-plugin>
+-- @
+--
+--
+-- To write all logs to stderr, including logs of the server, use:
+--
+-- @
+--   HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin>
+-- @
+mkPluginTestDescriptor
+  :: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState)
+  -> PluginId
+  -> PluginTestDescriptor b
+mkPluginTestDescriptor pluginDesc plId recorder = pluginDesc recorder plId
+
+-- | Wrap a plugin you want to test.
+--
+-- Ideally, try to migrate this plugin to co-log logger style architecture.
+-- Therefore, you should prefer 'mkPluginTestDescriptor' to this if possible.
+mkPluginTestDescriptor'
+  :: (PluginId -> PluginDescriptor IdeState)
+  -> PluginId
+  -> PluginTestDescriptor b
+mkPluginTestDescriptor' pluginDesc plId _recorder = pluginDesc plId
+
+-- | Initialise a recorder that can be instructed to write to stderr by
+-- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before
+-- running the tests.
+--
+-- On the cli, use for example:
+--
+-- @
+--   HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test <test-suite-of-plugin>
+-- @
+--
+-- To write all logs to stderr, including logs of the server, use:
+--
+-- @
+--   HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin>
+-- @
+pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
+pluginTestRecorder = do
+  (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"]
+  pure recorder
+
+-- | Generic recorder initialisation for plugins and the HLS server for test-cases.
+--
+-- The created recorder writes to stderr if any of the given environment variables
+-- have been set to a value different to @0@.
+-- We allow multiple values, to make it possible to define a single environment variable
+-- that instructs all recorders in the test-suite to write to stderr.
+--
+-- We have to return the base logger function for HLS server logging initialisation.
+-- See 'runSessionWithServer'' for details.
+initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
+initialiseTestRecorder envVars = do
+    docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug
+    -- There are potentially multiple environment variables that enable this logger
+    definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var)
+    let logStdErr = any (/= "0") definedEnvVars
+
+        docWithFilteredPriorityRecorder =
+          if logStdErr then cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder
+          else mempty
+
+        Recorder {logger_} = docWithFilteredPriorityRecorder
+
+    pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_)
 
-runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
-runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps
+-- ------------------------------------------------------------
+-- Run an HLS server testing a specific plugin
+-- ------------------------------------------------------------
 
-runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a
-runSessionWithServerFormatter plugin formatter conf =
+runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a
+runSessionWithServer plugin fp act = do
+  recorder <- pluginTestRecorder
+  runSessionWithServer' [plugin recorder] def def fullCaps fp act
+
+runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a
+runSessionWithServerAndCaps plugin caps fp act = do
+  recorder <- pluginTestRecorder
+  runSessionWithServer' [plugin recorder] def def caps fp act
+
+runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
+runSessionWithServerFormatter plugin formatter conf fp act = do
+  recorder <- pluginTestRecorder
   runSessionWithServer'
-    [plugin]
+    [plugin recorder]
     def
       { formattingProvider = T.pack formatter
       , plugins = M.singleton (T.pack formatter) conf
       }
     def
     fullCaps
+    fp
+    act
 
 goldenWithHaskellDocFormatter
-  :: PluginDescriptor IdeState -- ^ Formatter plugin to be used
+  :: Pretty b
+  => PluginTestDescriptor b -- ^ Formatter plugin to be used
   -> String -- ^ Name of the formatter to be used
   -> PluginConfig
   -> TestName -- ^ Title of the test
@@ -195,7 +309,8 @@ goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc
     documentContents doc
 
 goldenWithCabalDocFormatter
-  :: PluginDescriptor IdeState -- ^ Formatter plugin to be used
+  :: Pretty b
+  => PluginTestDescriptor b -- ^ Formatter plugin to be used
   -> String -- ^ Name of the formatter to be used
   -> PluginConfig
   -> TestName -- ^ Title of the test
@@ -215,16 +330,18 @@ goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ex
     act doc
     documentContents doc
 
-runSessionWithCabalServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a
-runSessionWithCabalServerFormatter plugin formatter conf =
+runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
+runSessionWithCabalServerFormatter plugin formatter conf fp act = do
+  recorder <- pluginTestRecorder
   runSessionWithServer'
-    [plugin]
+    [plugin recorder]
     def
       { cabalFormattingProvider = T.pack formatter
       , plugins = M.singleton (T.pack formatter) conf
       }
     def
     fullCaps
+    fp act
 
 -- | Restore cwd after running an action
 keepCurrentDirectory :: IO a -> IO a
@@ -235,11 +352,13 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const
 lock :: Lock
 lock = unsafePerformIO newLock
 
-
 -- | Host a server, and run a test session on it
 -- Note: cwd will be shifted into @root@ in @Session a@
 runSessionWithServer' ::
-  -- | plugins to load on the server
+  -- | Plugins to load on the server.
+  --
+  -- For improved logging, make sure these plugins have been initalised with
+  -- the recorder produced by @pluginTestRecorder@.
   [PluginDescriptor IdeState] ->
   -- | lsp config for the server
   Config ->
@@ -253,20 +372,19 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
     (inR, inW) <- createPipe
     (outR, outW) <- createPipe
 
-    docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug
-
-    logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR"
+    -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before,
+    -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it
+    -- uses a more descriptive name.
+    -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR".
+    -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins
+    -- under test.
+    (recorder, logger_) <- initialiseTestRecorder
+      ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"]
 
     let
-        docWithFilteredPriorityRecorder@Recorder{ logger_ } =
-            if logStdErr == "0" then mempty
-            else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder
-
         -- exists until old logging style is phased out
         logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))
 
-        recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder
-
         arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger
 
         hlsPlugins =

plugins/hls-alternate-number-format-plugin/test/Main.hs

@@ -19,8 +19,8 @@ import           Text.Regex.TDFA                  ((=~))
 main :: IO ()
 main = defaultTestRunner test
 
-alternateNumberFormatPlugin :: PluginDescriptor IdeState
-alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty  "alternateNumberFormat"
+alternateNumberFormatPlugin :: PluginTestDescriptor AlternateNumberFormat.Log
+alternateNumberFormatPlugin = mkPluginTestDescriptor AlternateNumberFormat.descriptor "alternateNumberFormat"
 
 -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time.
 -- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something

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

@@ -10,8 +10,8 @@ import           Test.Hls
 main :: IO ()
 main = defaultTestRunner tests
 
-brittanyPlugin :: PluginDescriptor IdeState
-brittanyPlugin = Brittany.descriptor "brittany"
+brittanyPlugin :: PluginTestDescriptor ()
+brittanyPlugin = mkPluginTestDescriptor' Brittany.descriptor "brittany"
 
 tests :: TestTree
 tests = testGroup "brittany"

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

@@ -30,8 +30,8 @@ main = do
   foundCabalFmt <- isCabalFmtFound
   defaultTestRunner (tests foundCabalFmt)
 
-cabalFmtPlugin :: PluginDescriptor IdeState
-cabalFmtPlugin = CabalFmt.descriptor mempty "cabal-fmt"
+cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log
+cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt"
 
 tests :: CabalFmtFound -> TestTree
 tests found = testGroup "cabal-fmt"