From fa573a3c7ec3c2654567606e86683c16a50f5f48 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 19 Nov 2022 18:36:57 +0100 Subject: [PATCH 01/32] Add generic test plugin recorder initialisation --- hls-test-utils/src/Test/Hls.hs | 87 ++++++++++++++++++++++++++++++---- 1 file changed, 78 insertions(+), 9 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index a9d3a595f3..f883ca2b55 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -20,7 +20,9 @@ module Test.Hls goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, def, + pluginTestRecorder, runSessionWithServer, + runSessionWithServerAndRecorder, runSessionWithServerFormatter, runSessionWithCabalServerFormatter, runSessionWithServer', @@ -35,6 +37,11 @@ module Test.Hls getLastBuildKeys, waitForKickDone, waitForKickStart, + -- * Re-export logger types + -- Avoids slightly annoying ghcide imports when they are unnecessary. + WithPriority(..), + Recorder, + Priority(..), ) where @@ -99,6 +106,8 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun import Test.Tasty.Runners (NumThreads (..)) +import Control.Monad.Extra (forM) +import Development.IDE.Types.Logger (Doc) newtype Log = LogIDEMain IDEMain.Log @@ -158,10 +167,34 @@ goldenWithDoc fileType plugin title testDataDir path desc ext act = act doc documentContents doc +goldenWithHaskellDocAndRecorder + :: Pretty a + => (Recorder (WithPriority a) -> PluginDescriptor IdeState) + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithHaskellDocAndRecorder plugin title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServerAndRecorder plugin testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps +runSessionWithServerAndRecorder :: Pretty b => (Recorder (WithPriority b) -> PluginDescriptor IdeState) -> FilePath -> Session a -> IO a +runSessionWithServerAndRecorder pluginF fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' [pluginF recorder] def def fullCaps fp act + runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a runSessionWithServerFormatter plugin formatter conf = runSessionWithServer' @@ -235,6 +268,46 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock +-- | 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 +-- @ +-- +-- to write all logs to stderr. +pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a)) +pluginTestRecorder = do + (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_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 mempty + else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + + Recorder {logger_} = docWithFilteredPriorityRecorder + + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) + -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ @@ -253,20 +326,16 @@ 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 two 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" + (recorder, logger_) <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_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 = From ee4bdc18a5749010b0bbc2b5b8a8cad9cd8be956 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 19 Nov 2022 19:10:06 +0100 Subject: [PATCH 02/32] Migrate some plugins to the new test plugin recorder structure --- .../test/Main.hs | 8 +++--- plugins/hls-cabal-fmt-plugin/test/Main.hs | 6 ++--- plugins/hls-class-plugin/test/Main.hs | 4 +-- plugins/hls-code-range-plugin/test/Main.hs | 2 +- plugins/hls-eval-plugin/test/Main.hs | 26 +++++++++---------- 5 files changed, 23 insertions(+), 23 deletions(-) diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index c71fffb9e8..65716b78c1 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/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 :: Recorder (WithPriority AlternateNumberFormat.Log) -> PluginDescriptor IdeState +alternateNumberFormatPlugin recorder = AlternateNumberFormat.descriptor recorder "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 @@ -54,7 +54,7 @@ test = testGroup "alternateNumberFormat" [ codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree codeActionProperties fp locs assertions = testCase fp $ do - runSessionWithServer alternateNumberFormatPlugin testDataDir $ do + runSessionWithServerAndRecorder alternateNumberFormatPlugin testDataDir $ do openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findAlternateNumberActions >>= assertions where -- similar to codeActionTest @@ -75,7 +75,7 @@ testDataDir :: FilePath testDataDir = "test" "testdata" goldenAlternateFormat :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenAlternateFormat fp = goldenWithHaskellDoc alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenAlternateFormat fp = goldenWithHaskellDoc (alternateNumberFormatPlugin mempty) (fp <> " (golden)") testDataDir fp "expected" "hs" codeActionTest :: (Maybe Text -> Bool) -> FilePath -> Int -> Int -> TestTree codeActionTest filter' fp line col = goldenAlternateFormat fp $ \doc -> do diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs index 35d6fe6ba8..453839fb38 100644 --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/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 :: Recorder (WithPriority CabalFmt.Log) -> PluginDescriptor IdeState +cabalFmtPlugin recorder = CabalFmt.descriptor recorder "cabal-fmt" tests :: CabalFmtFound -> TestTree tests found = testGroup "cabal-fmt" @@ -52,7 +52,7 @@ cabalFmtGolden NotFound title _ _ _ = testCase title $ assertFailure $ "Couldn't find cabal-fmt on PATH or this is not an isolated run. " <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally." -cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act +cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter (cabalFmtPlugin mempty) "cabal-fmt" conf title testDataDir path desc "cabal" act where conf = def diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 585f49143e..6f89f64857 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -25,8 +25,8 @@ import Test.Hls main :: IO () main = do - recorder <- makeDefaultStderrRecorder Nothing Debug - defaultTestRunner . tests $ contramap (fmap pretty) recorder + recorder <- pluginTestRecorder + defaultTestRunner . tests $ recorder classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState classPlugin recorder = Class.descriptor recorder "class" diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 5ad43de5f2..5dfd8c8864 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -23,7 +23,7 @@ plugin recorder = descriptor recorder "codeRange" main :: IO () main = do - recorder <- contramap (fmap pretty) <$> makeDefaultStderrRecorder Nothing Debug + recorder <- pluginTestRecorder defaultTestRunner $ testGroup "Code Range" [ testGroup "Integration Tests" [ diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index cc2baa3ac6..bb34b432d9 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -29,34 +29,34 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -evalPlugin :: PluginDescriptor IdeState -evalPlugin = Eval.descriptor mempty "eval" +evalPlugin :: Recorder (WithPriority Eval.Log) -> PluginDescriptor IdeState +evalPlugin recorder = Eval.descriptor recorder "eval" tests :: TestTree tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] @@ -194,7 +194,7 @@ tests = not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ] , testCase "Interfaces are reused after Eval" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc "TLocalImport.hs" "haskell" waitForTypecheck doc lenses <- getCodeLenses doc @@ -213,13 +213,13 @@ tests = goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = - goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards + goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path "expected" ext executeLensesBackwards -- | Similar function as 'goldenWithEval' with an alternate reference file -- naming. Useful when reference file may change because of GHC version. goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEval' title path ext expected = - goldenWithHaskellDoc evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path expected ext executeLensesBackwards -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () @@ -246,7 +246,7 @@ executeCmd cmd = do pure () evalLenses :: FilePath -> IO [CodeLens] -evalLenses path = runSessionWithServer evalPlugin testDataDir $ do +evalLenses path = runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc @@ -280,12 +280,12 @@ exceptionConfig exCfg = changeConfig ["exception" .= exCfg] goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = - goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do + goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path expected ext $ \doc -> do sendConfigurationChanged (toJSON cfg) executeLensesBackwards doc evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () -evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do +evalInFile fp e expected = runSessionWithServerAndRecorder evalPlugin testDataDir $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e From 3256d6d587d7f725862f2fb4def147ca152c4255 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:05:09 +0100 Subject: [PATCH 03/32] Introduce improved Test Logging Infrastructure Every plugin should use the new functions. This way, we can guarantee predictable logging behaviour for tests. Most notably, we now have a single control point, for co-log style logging, how to write logs to stderr, and how to write logs for server and plugin at the same time. --- hls-test-utils/src/Test/Hls.hs | 225 ++++++++++++++++++++------------- 1 file changed, 137 insertions(+), 88 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index f883ca2b55..4e5c25a9a1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -20,16 +20,18 @@ module Test.Hls goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, def, - pluginTestRecorder, + -- * Running HLS for integration tests runSessionWithServer, - runSessionWithServerAndRecorder, + runSessionWithServerAndCaps, runSessionWithServerFormatter, runSessionWithCabalServerFormatter, runSessionWithServer', - waitForProgressDone, - waitForAllProgressDone, + -- * Helpful re-exports PluginDescriptor, IdeState, + -- * Assertion helper functions + waitForProgressDone, + waitForAllProgressDone, waitForBuildQueue, waitForTypecheck, waitForAction, @@ -37,6 +39,11 @@ module Test.Hls 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(..), @@ -50,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, @@ -69,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_), @@ -106,8 +114,6 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun import Test.Tasty.Runners (NumThreads (..)) -import Control.Monad.Extra (forM) -import Development.IDE.Types.Logger (Doc) newtype Log = LogIDEMain IDEMain.Log @@ -126,7 +132,8 @@ goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree goldenGitDiff name = goldenVsStringDiff name gitDiff goldenWithHaskellDoc - :: PluginDescriptor IdeState + :: Pretty b + => PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -137,7 +144,8 @@ goldenWithHaskellDoc goldenWithHaskellDoc = goldenWithDoc "haskell" goldenWithCabalDoc - :: PluginDescriptor IdeState + :: Pretty b + => PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -148,8 +156,9 @@ goldenWithCabalDoc goldenWithCabalDoc = goldenWithDoc "cabal" goldenWithDoc - :: T.Text - -> PluginDescriptor IdeState + :: Pretty b + => T.Text + -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -167,47 +176,119 @@ goldenWithDoc fileType plugin title testDataDir path desc ext act = act doc documentContents doc -goldenWithHaskellDocAndRecorder - :: Pretty a - => (Recorder (WithPriority a) -> PluginDescriptor IdeState) - -> TestName - -> FilePath - -> FilePath - -> FilePath - -> FilePath - -> (TextDocumentIdentifier -> Session ()) - -> TestTree -goldenWithHaskellDocAndRecorder plugin title testDataDir path desc ext act = - goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerAndRecorder plugin testDataDir - $ TL.encodeUtf8 . TL.fromStrict - <$> do - doc <- openDoc (path <.> ext) "haskell" - void waitForBuildQueue - 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 +-- @ +-- +-- +-- To write all logs to stderr, including logs of the server, use: +-- +-- @ +-- HLS_TEST_LOG_STDERR=1 cabal test +-- @ +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 +-- @ +-- +-- To write all logs to stderr, including logs of the server, use: +-- +-- @ +-- HLS_TEST_LOG_STDERR=1 cabal test +-- @ +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 -runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a -runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps + Recorder {logger_} = docWithFilteredPriorityRecorder + + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) -runSessionWithServerAndRecorder :: Pretty b => (Recorder (WithPriority b) -> PluginDescriptor IdeState) -> FilePath -> Session a -> IO a -runSessionWithServerAndRecorder pluginF fp act = do +-- ------------------------------------------------------------ +-- Run an HLS server testing a specific plugin +-- ------------------------------------------------------------ + +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' [pluginF recorder] def def fullCaps fp act + runSessionWithServer' [plugin recorder] def def caps fp act -runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithServerFormatter plugin formatter conf = +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 @@ -228,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 @@ -248,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 @@ -268,51 +352,13 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock --- | 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 --- @ --- --- to write all logs to stderr. -pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a)) -pluginTestRecorder = do - (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_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 mempty - else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder - - Recorder {logger_} = docWithFilteredPriorityRecorder - - pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) - - -- | 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 -> @@ -326,11 +372,14 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - -- Allow two environment variables, because "LSP_TEST_LOG_STDERR" has been used before, + -- 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" - (recorder, logger_) <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR"] + -- 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 -- exists until old logging style is phased out From 9c97a1623a81512b555aec0cee259dce33f3d906 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:23:42 +0100 Subject: [PATCH 04/32] HlsPlugins: Make sure every plugin is imported qualified --- src/HlsPlugins.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 6fe2e4ef24..ac0136c7bd 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -85,19 +85,19 @@ import qualified Ide.Plugin.CodeRange as CodeRange #endif #if hls_changeTypeSignature -import Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature #endif #if hls_gadt -import Ide.Plugin.GADT as GADT +import qualified Ide.Plugin.GADT as GADT #endif #if explicitFixity -import Ide.Plugin.ExplicitFixity as ExplicitFixity +import qualified Ide.Plugin.ExplicitFixity as ExplicitFixity #endif #if explicitFields -import Ide.Plugin.ExplicitFields as ExplicitFields +import qualified Ide.Plugin.ExplicitFields as ExplicitFields #endif -- formatters From f4ee7fecc2074a1c601824a603f8dcc6f3dc874f Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:05:27 +0100 Subject: [PATCH 05/32] hls-cabal-plugin: Unify logging infrastructure --- plugins/hls-cabal-plugin/test/Main.hs | 51 +++++++++------------------ 1 file changed, 16 insertions(+), 35 deletions(-) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 9fb01274b6..03a8976bb1 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -11,9 +11,7 @@ import Control.Lens ((^.)) import Control.Monad (guard) import qualified Data.ByteString as BS import Data.Either (isRight) -import Data.Function import qualified Data.Text as Text -import Development.IDE.Types.Logger import Ide.Plugin.Cabal import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib @@ -21,34 +19,17 @@ import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls - -cabalPlugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState -cabalPlugin recorder = descriptor recorder "cabal" +cabalPlugin :: PluginTestDescriptor Log +cabalPlugin = mkPluginTestDescriptor descriptor "cabal" main :: IO () main = do - recorder <- initialiseRecorder True defaultTestRunner $ testGroup "Cabal Plugin Tests" [ unitTests - , pluginTests recorder + , pluginTests ] --- | @initialiseRecorder silent@ --- --- If @'silent' == True@, then don't log anything, otherwise --- the recorder is the standard recorder of HLS. Useful for debugging. -initialiseRecorder :: Bool -> IO (Recorder (WithPriority Log)) -initialiseRecorder True = pure mempty -initialiseRecorder False = do - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug - - let docWithFilteredPriorityRecorder = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= Debug) - pure $ docWithFilteredPriorityRecorder - & cmapWithPrio pretty - -- ------------------------------------------------------------------------ -- Unit Tests -- ------------------------------------------------------------------------ @@ -89,10 +70,10 @@ codeActionUnitTests = testGroup "Code Action Tests" -- Integration Tests -- ------------------------------------------------------------------------ -pluginTests :: Recorder (WithPriority Log) -> TestTree -pluginTests recorder = testGroup "Plugin Tests" +pluginTests :: TestTree +pluginTests = testGroup "Plugin Tests" [ testGroup "Diagnostics" - [ runCabalTestCaseSession "Publishes Diagnostics on Error" recorder "" $ do + [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do doc <- openDoc "invalid.cabal" "cabal" diags <- waitForDiagnosticsFromSource doc "cabal" unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] @@ -100,7 +81,7 @@ pluginTests recorder = testGroup "Plugin Tests" length diags @?= 1 unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. J.severity @?= Just DsError - , runCabalTestCaseSession "Clears diagnostics" recorder "" $ do + , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" diags <- waitForDiagnosticsFrom doc unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] @@ -111,13 +92,13 @@ pluginTests recorder = testGroup "Plugin Tests" _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" newDiags <- waitForDiagnosticsFrom doc liftIO $ newDiags @?= [] - , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" recorder "simple-cabal" $ do + , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do hsDoc <- openDoc "A.hs" "haskell" expectNoMoreDiagnostics 1 hsDoc "typechecking" cabalDoc <- openDoc "simple-cabal.cabal" "cabal" expectNoMoreDiagnostics 1 cabalDoc "parsing" , ignoreTestBecause "Testcase is flaky for certain GHC versions (e.g. 9.2.4). See #3333 for details." $ do - runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" recorder "simple-cabal" $ do + runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "simple-cabal" $ do hsDoc <- openDoc "A.hs" "haskell" expectNoMoreDiagnostics 1 hsDoc "typechecking" cabalDoc <- openDoc "simple-cabal.cabal" "cabal" @@ -134,7 +115,7 @@ pluginTests recorder = testGroup "Plugin Tests" unknownLicenseDiag ^. J.severity @?= Just DsError ] , testGroup "Code Actions" - [ runCabalTestCaseSession "BSD-3" recorder "" $ do + [ runCabalTestCaseSession "BSD-3" "" $ do doc <- openDoc "licenseCodeAction.cabal" "cabal" diags <- waitForDiagnosticsFromSource doc "cabal" reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] @@ -155,7 +136,7 @@ pluginTests recorder = testGroup "Plugin Tests" , " build-depends: base" , " default-language: Haskell2010" ] - , runCabalTestCaseSession "Apache-2.0" recorder "" $ do + , runCabalTestCaseSession "Apache-2.0" "" $ do doc <- openDoc "licenseCodeAction2.cabal" "cabal" diags <- waitForDiagnosticsFromSource doc "cabal" -- test if it supports typos in license name, here 'apahe' @@ -190,12 +171,12 @@ pluginTests recorder = testGroup "Plugin Tests" -- Runner utils -- ------------------------------------------------------------------------ -runCabalTestCaseSession :: TestName -> Recorder (WithPriority Log) -> FilePath -> Session () -> TestTree -runCabalTestCaseSession title recorder subdir act = testCase title $ runCabalSession recorder subdir act +runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir -runCabalSession :: Recorder (WithPriority Log) -> FilePath -> Session a -> IO a -runCabalSession recorder subdir = - failIfSessionTimeout . runSessionWithServer (cabalPlugin recorder) (testDataDir subdir) +runCabalSession :: FilePath -> Session a -> IO a +runCabalSession subdir = + failIfSessionTimeout . runSessionWithServer cabalPlugin (testDataDir subdir) testDataDir :: FilePath testDataDir = "test" "testdata" From 10f2116be0ddb1b92060356f398a6ecb5db704bd Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:21:13 +0100 Subject: [PATCH 06/32] hls-cabal-fmt-plugin: Unify logging infrastructure --- plugins/hls-cabal-fmt-plugin/test/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs index 453839fb38..54c95eddb9 100644 --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/plugins/hls-cabal-fmt-plugin/test/Main.hs @@ -30,8 +30,8 @@ main = do foundCabalFmt <- isCabalFmtFound defaultTestRunner (tests foundCabalFmt) -cabalFmtPlugin :: Recorder (WithPriority CabalFmt.Log) -> PluginDescriptor IdeState -cabalFmtPlugin recorder = CabalFmt.descriptor recorder "cabal-fmt" +cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log +cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt" tests :: CabalFmtFound -> TestTree tests found = testGroup "cabal-fmt" @@ -52,7 +52,7 @@ cabalFmtGolden NotFound title _ _ _ = testCase title $ assertFailure $ "Couldn't find cabal-fmt on PATH or this is not an isolated run. " <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally." -cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter (cabalFmtPlugin mempty) "cabal-fmt" conf title testDataDir path desc "cabal" act +cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act where conf = def From ac1fcd2e719cbbef42b9c1212d44130b8656f492 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:23:14 +0100 Subject: [PATCH 07/32] hls-alternate-number-format-plugin: Unify logging infrastructure --- plugins/hls-alternate-number-format-plugin/test/Main.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index 65716b78c1..cf12422ee7 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -19,8 +19,8 @@ import Text.Regex.TDFA ((=~)) main :: IO () main = defaultTestRunner test -alternateNumberFormatPlugin :: Recorder (WithPriority AlternateNumberFormat.Log) -> PluginDescriptor IdeState -alternateNumberFormatPlugin recorder = AlternateNumberFormat.descriptor recorder "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 @@ -54,7 +54,7 @@ test = testGroup "alternateNumberFormat" [ codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree codeActionProperties fp locs assertions = testCase fp $ do - runSessionWithServerAndRecorder alternateNumberFormatPlugin testDataDir $ do + runSessionWithServer alternateNumberFormatPlugin testDataDir $ do openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findAlternateNumberActions >>= assertions where -- similar to codeActionTest @@ -75,7 +75,7 @@ testDataDir :: FilePath testDataDir = "test" "testdata" goldenAlternateFormat :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenAlternateFormat fp = goldenWithHaskellDoc (alternateNumberFormatPlugin mempty) (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenAlternateFormat fp = goldenWithHaskellDoc alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" codeActionTest :: (Maybe Text -> Bool) -> FilePath -> Int -> Int -> TestTree codeActionTest filter' fp line col = goldenAlternateFormat fp $ \doc -> do From 5f1b9077c2e1c51aecadb4c588b076bd5c707554 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:24:16 +0100 Subject: [PATCH 08/32] hls-brittany-plugin: Unify logging infrastructure --- plugins/hls-brittany-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-brittany-plugin/test/Main.hs b/plugins/hls-brittany-plugin/test/Main.hs index a7a840d7c3..0483ecbabe 100644 --- a/plugins/hls-brittany-plugin/test/Main.hs +++ b/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" From bf96936cafc3967e350d345d74789d2ef19e5e8d Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:28:14 +0100 Subject: [PATCH 09/32] hls-call-hierarchy-plugin: Unify logging infrastructure --- .../hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs | 4 ++-- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 4 ---- plugins/hls-call-hierarchy-plugin/test/Main.hs | 4 ++-- src/HlsPlugins.hs | 2 +- 4 files changed, 5 insertions(+), 9 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index cf7e042986..3e0da1afde 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -5,8 +5,8 @@ import qualified Ide.Plugin.CallHierarchy.Internal as X import Ide.Types import Language.LSP.Types -descriptor :: PluginDescriptor IdeState -descriptor = (defaultPluginDescriptor X.callHierarchyId) +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index db148733ec..2b23688fd3 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -11,7 +11,6 @@ module Ide.Plugin.CallHierarchy.Internal ( prepareCallHierarchy , incomingCalls , outgoingCalls -, callHierarchyId ) where import Control.Lens ((^.)) @@ -38,9 +37,6 @@ import Language.LSP.Types import qualified Language.LSP.Types.Lens as L import Text.Read (readMaybe) -callHierarchyId :: PluginId -callHierarchyId = PluginId "callHierarchy" - -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = pluginResponse $ do diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index bbd8c44b93..93ff69b062 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -21,8 +21,8 @@ import qualified System.IO.Extra import Test.Hls import Test.Hls.Util (withCanonicalTempDir) -plugin :: PluginDescriptor IdeState -plugin = descriptor +plugin :: PluginTestDescriptor () +plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" main :: IO () main = defaultTestRunner $ diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index ac0136c7bd..a62e9779c4 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -182,7 +182,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins Brittany.descriptor "brittany" : #endif #if hls_callHierarchy - CallHierarchy.descriptor : + CallHierarchy.descriptor "callHierarchy" : #endif #if hls_class let pId = "class" in Class.descriptor (pluginRecorder pId) pId: From 4103f7aaed83221ff246467a9ca96b4ff37a6b26 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:35:37 +0100 Subject: [PATCH 10/32] hls-change-type-signature-plugin: Unify logging infrastructure --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 31 +++++++++---------- .../test/Main.hs | 16 +++++----- src/HlsPlugins.hs | 2 +- 3 files changed, 24 insertions(+), 25 deletions(-) diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index e18a2dac36..5374761a14 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -12,7 +12,6 @@ import Control.Monad.Trans.Except (ExceptT) import Data.Foldable (asum) import qualified Data.HashMap.Strict as Map import Data.Maybe (mapMaybe) -import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import Development.IDE (realSrcSpanToRange) @@ -25,30 +24,28 @@ import Generics.SYB (extQ, something) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types (PluginDescriptor (..), + PluginId (PluginId), PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Types import Text.Regex.TDFA ((=~)) -changeTypeSignatureId :: IsString a => a -changeTypeSignatureId = "changeTypeSignature" +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeActionHandler plId) } -descriptor :: PluginDescriptor IdeState -descriptor = (defaultPluginDescriptor changeTypeSignatureId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler } - -codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction -codeActionHandler ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = pluginResponse $ do +codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = pluginResponse $ do nfp <- getNormalizedFilePath uri - decls <- getDecls ideState nfp - let actions = mapMaybe (generateAction uri decls) diags + decls <- getDecls plId ideState nfp + let actions = mapMaybe (generateAction plId uri decls) diags pure $ List actions -getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] -getDecls state = handleMaybeM "Could not get Parsed Module" +getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] +getDecls (PluginId changeTypeSignatureId) state = handleMaybeM "Could not get Parsed Module" . liftIO . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source)) - . runAction (changeTypeSignatureId <> ".GetParsedModule") state + . runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state . use GetParsedModule -- | Text representing a Declaration's Name @@ -76,8 +73,8 @@ data ChangeSignature = ChangeSignature { type SigName = (HasOccName (IdP GhcPs)) -- | Create a CodeAction from a Diagnostic -generateAction :: SigName => Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction) -generateAction uri decls diag = changeSigToCodeAction uri <$> diagnosticToChangeSig decls diag +generateAction :: SigName => PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction) +generateAction plId uri decls diag = changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls diag -- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature @@ -148,8 +145,8 @@ stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig then T.strip $ snd $ T.breakOnEnd " => " sig else T.strip $ snd $ T.breakOnEnd " :: " sig -changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction -changeSigToCodeAction uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType +changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction +changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType , _kind = Just (CodeActionUnknown ("quickfix." <> changeTypeSignatureId)) , _diagnostics = Just $ List [diagnostic] , _isPreferred = Nothing diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index 3aba829522..84d9b8ef90 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -9,8 +9,8 @@ import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes) import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature import System.FilePath ((<.>), ()) import Test.Hls (CodeAction (..), Command, - GhcVersion (..), IdeState, - PluginDescriptor, + GhcVersion (..), + PluginTestDescriptor, Position (Position), Range (Range), Session, TestName, TestTree, @@ -21,9 +21,11 @@ import Test.Hls (CodeAction (..), Command, getCodeActions, goldenWithHaskellDoc, knownBrokenForGhcVersions, - liftIO, openDoc, - runSessionWithServer, testCase, - testGroup, toEither, type (|?), + liftIO, + mkPluginTestDescriptor', + openDoc, runSessionWithServer, + testCase, testGroup, toEither, + type (|?), waitForAllProgressDone, waitForDiagnostics, (@?=)) import Text.Regex.TDFA ((=~)) @@ -31,8 +33,8 @@ import Text.Regex.TDFA ((=~)) main :: IO () main = defaultTestRunner test -changeTypeSignaturePlugin :: PluginDescriptor IdeState -changeTypeSignaturePlugin = ChangeTypeSignature.descriptor +changeTypeSignaturePlugin :: PluginTestDescriptor () +changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature" test :: TestTree test = testGroup "changeTypeSignature" [ diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index a62e9779c4..21f1ec4e9b 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -221,7 +221,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "codeRange" in CodeRange.descriptor (pluginRecorder pId) pId: #endif #if hls_changeTypeSignature - ChangeTypeSignature.descriptor : + ChangeTypeSignature.descriptor "changeTypeSignature" : #endif #if hls_gadt GADT.descriptor "gadt" : From 8540a048d92829a9809ebaa32c07d9bdaa46fa7e Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:40:54 +0100 Subject: [PATCH 11/32] hls-class-plugin: Unify logging infrastructure --- plugins/hls-class-plugin/test/Main.hs | 92 ++++++++++++--------------- 1 file changed, 42 insertions(+), 50 deletions(-) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 6f89f64857..c9c14aa85c 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -9,38 +9,30 @@ module Main ( main ) where -import Control.Lens (Prism', prism', (^.), (^..), - (^?)) -import Control.Monad (void) -import Data.Aeson (toJSON, (.=)) -import Data.Functor.Contravariant (contramap) +import Control.Lens (Prism', prism', (^.), (^..), (^?)) +import Control.Monad (void) import Data.Maybe -import Development.IDE.Types.Logger -import qualified Ide.Plugin.Class as Class -import Ide.Plugin.Config (PluginConfig (plcConfig)) -import qualified Ide.Plugin.Config as Plugin -import qualified Language.LSP.Types.Lens as J +import qualified Ide.Plugin.Class as Class +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls main :: IO () -main = do - recorder <- pluginTestRecorder - defaultTestRunner . tests $ recorder +main = defaultTestRunner tests -classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState -classPlugin recorder = Class.descriptor recorder "class" +classPlugin :: PluginTestDescriptor Class.Log +classPlugin = mkPluginTestDescriptor Class.descriptor "class" -tests :: Recorder (WithPriority Class.Log) -> TestTree -tests recorder = testGroup +tests :: TestTree +tests = testGroup "class" - [codeActionTests recorder , codeLensTests recorder] + [codeActionTests, codeLensTests] -codeActionTests :: Recorder (WithPriority Class.Log) -> TestTree -codeActionTests recorder = testGroup +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do - runSessionWithServer (classPlugin recorder) testDataDir $ do + runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" caResults <- getAllCodeActions doc @@ -51,40 +43,40 @@ codeActionTests recorder = testGroup , Just "Add placeholders for '/='" , Just "Add placeholders for '/=' with signature(s)" ] - , goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do + , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do executeCodeAction eqAction - , goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do + , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do executeCodeAction neAction - , goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do + , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do executeCodeAction fmapAction - , goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do + , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do + , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do + , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction - , goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do executeCodeAction eqAction - , goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do + , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do executeCodeAction gAction - , goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do + , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do executeCodeAction ghAction , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ - goldenWithClass recorder "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do + goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do + , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do + , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do + , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do executeCodeAction multi ] -codeLensTests :: Recorder (WithPriority Class.Log) -> TestTree -codeLensTests recorder = testGroup +codeLensTests :: TestTree +codeLensTests = testGroup "code lens" [ testCase "Has code lens" $ do - runSessionWithServer (classPlugin recorder) testDataDir $ do + runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" lens <- getCodeLenses doc let titles = map (^. J.title) $ mapMaybe (^. J.command) lens @@ -92,14 +84,14 @@ codeLensTests recorder = testGroup [ "(==) :: B -> B -> Bool" , "(==) :: A -> A -> Bool" ] - , goldenCodeLens recorder "Apply code lens" "CodeLensSimple" 1 - , goldenCodeLens recorder "Apply code lens for local class" "LocalClassDefine" 0 - , goldenCodeLens recorder "Apply code lens on the same line" "Inline" 0 - , goldenCodeLens recorder "Don't insert pragma while existing" "CodeLensWithPragma" 0 + , goldenCodeLens "Apply code lens" "CodeLensSimple" 1 + , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 + , goldenCodeLens "Apply code lens on the same line" "Inline" 0 + , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0 , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ - goldenCodeLens recorder "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 - , goldenCodeLens recorder "Qualified name" "Qualified" 0 - , goldenCodeLens recorder "Type family" "TypeFamily" 0 + goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 + , goldenCodeLens "Qualified name" "Qualified" 0 + , goldenCodeLens "Type family" "TypeFamily" 0 ] _CACodeAction :: Prism' (Command |? CodeAction) CodeAction @@ -108,16 +100,16 @@ _CACodeAction = prism' InR $ \case _ -> Nothing -goldenCodeLens :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> Int -> TestTree -goldenCodeLens recorder title path idx = - goldenWithHaskellDoc (classPlugin recorder) title testDataDir path "expected" "hs" $ \doc -> do +goldenCodeLens :: TestName -> FilePath -> Int -> TestTree +goldenCodeLens title path idx = + goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do lens <- getCodeLenses doc executeCommand $ fromJust $ (lens !! idx) ^. J.command void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) -goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree -goldenWithClass recorder title path desc act = - goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do +goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree +goldenWithClass title path desc act = + goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do _ <- waitForDiagnosticsFromSource doc "typecheck" actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions From ad7fe9b7ddb380b402503ffcf28b65bb1123c4ff Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:43:06 +0100 Subject: [PATCH 12/32] hls-code-range-plugin: Unify logging infrastructure --- plugins/hls-code-range-plugin/test/Main.hs | 25 +++++++++++----------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 5dfd8c8864..2b5f018e4f 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -18,19 +18,18 @@ import Language.LSP.Types.Lens import System.FilePath ((<.>), ()) import Test.Hls -plugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState -plugin recorder = descriptor recorder "codeRange" +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "codeRange" main :: IO () main = do - recorder <- pluginTestRecorder defaultTestRunner $ testGroup "Code Range" [ testGroup "Integration Tests" [ - selectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], - selectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], - selectionRangeGoldenTest recorder "Empty" [(1, 5)], - foldingRangeGoldenTest recorder "Function" + selectionRangeGoldenTest "Import" [(4, 36), (1, 8)], + selectionRangeGoldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], + selectionRangeGoldenTest "Empty" [(1, 5)], + foldingRangeGoldenTest "Function" ], testGroup "Unit Tests" [ Ide.Plugin.CodeRangeTest.testTree, @@ -38,9 +37,9 @@ main = do ] ] -selectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree -selectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer (plugin recorder) testDataDir $ do +selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree +selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) @@ -67,9 +66,9 @@ selectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (t showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" showLBS = fromString . show -foldingRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> TestTree -foldingRangeGoldenTest recorder testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer (plugin recorder) testDataDir $ do +foldingRangeGoldenTest :: TestName -> TestTree +foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request STextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc let res = resp ^. result From 3f2f36e31668e208e85bcbf133558e38710fb3a2 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:44:21 +0100 Subject: [PATCH 13/32] hls-eval-plugin: Unify logging infrastructure --- plugins/hls-eval-plugin/test/Main.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index bb34b432d9..df9c83b4ac 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -29,34 +29,34 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -evalPlugin :: Recorder (WithPriority Eval.Log) -> PluginDescriptor IdeState -evalPlugin recorder = Eval.descriptor recorder "eval" +evalPlugin :: PluginTestDescriptor Eval.Log +evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval" tests :: TestTree tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] @@ -194,7 +194,7 @@ tests = not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ] , testCase "Interfaces are reused after Eval" $ do - runSessionWithServerAndRecorder evalPlugin testDataDir $ do + runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc "TLocalImport.hs" "haskell" waitForTypecheck doc lenses <- getCodeLenses doc @@ -213,13 +213,13 @@ tests = goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = - goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path "expected" ext executeLensesBackwards + goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards -- | Similar function as 'goldenWithEval' with an alternate reference file -- naming. Useful when reference file may change because of GHC version. goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEval' title path ext expected = - goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDoc evalPlugin title testDataDir path expected ext executeLensesBackwards -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () @@ -246,7 +246,7 @@ executeCmd cmd = do pure () evalLenses :: FilePath -> IO [CodeLens] -evalLenses path = runSessionWithServerAndRecorder evalPlugin testDataDir $ do +evalLenses path = runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc @@ -280,12 +280,12 @@ exceptionConfig exCfg = changeConfig ["exception" .= exCfg] goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = - goldenWithHaskellDocAndRecorder evalPlugin title testDataDir path expected ext $ \doc -> do + goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do sendConfigurationChanged (toJSON cfg) executeLensesBackwards doc evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () -evalInFile fp e expected = runSessionWithServerAndRecorder evalPlugin testDataDir $ do +evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e From 12ca6d0b37d3408526dd786956cd03ee0e139e40 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:46:03 +0100 Subject: [PATCH 14/32] hls-explicit-fixity-plugin: Unify logging infrastructure --- .../src/Ide/Plugin/ExplicitFixity.hs | 12 ++++++------ plugins/hls-explicit-fixity-plugin/test/Main.hs | 6 +++--- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs index 75e27856b5..29b30a94c2 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -1,32 +1,32 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Ide.Plugin.ExplicitFixity(descriptor) where +module Ide.Plugin.ExplicitFixity(descriptor, Log) where import Control.DeepSeq -import Control.Monad.Trans.Maybe import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Maybe import Data.Either.Extra import Data.Hashable import qualified Data.Map.Strict as M -import qualified Data.Set as S import Data.Maybe +import qualified Data.Set as S import qualified Data.Text as T import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Shake (addPersistentRule) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Spans.AtPoint import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.LSP.Notifications (ghcideNotificationsPluginPriority) +import Development.IDE.Spans.AtPoint import GHC.Generics (Generic) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, @@ -94,7 +94,7 @@ lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name lookupFixities hscEnv tcGblEnv names = liftIO $ fmap (fromMaybe M.empty . snd) - $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) + $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ M.traverseMaybeWithKey (\_ v -> v) $ M.fromSet lookupFixity names where diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs index 82d374029f..c62f368e6d 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -3,12 +3,12 @@ module Main where import qualified Data.Text as T -import Ide.Plugin.ExplicitFixity (descriptor) +import Ide.Plugin.ExplicitFixity (Log, descriptor) import System.FilePath import Test.Hls -plugin :: PluginDescriptor IdeState -plugin = descriptor mempty "explicit-fixity" +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "explicit-fixity" main :: IO () main = defaultTestRunner tests From bee02f33370b26e3002fb7701e0b35c1c8074252 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:46:52 +0100 Subject: [PATCH 15/32] hls-explicit-imports-plugin: Unify logging infrastructure --- plugins/hls-explicit-imports-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 498ee975fd..c52f1f7d33 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -15,8 +15,8 @@ import qualified Ide.Plugin.ExplicitImports as ExplicitImports import System.FilePath ((<.>), ()) import Test.Hls -explicitImportsPlugin :: PluginDescriptor IdeState -explicitImportsPlugin = ExplicitImports.descriptor mempty "explicitImports" +explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log +explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports" longModule :: T.Text longModule = "F" <> T.replicate 80 "o" From afb95c9bc710dcf5875fbe253478698916057f1f Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:50:44 +0100 Subject: [PATCH 16/32] hls-explicit-record-fields-plugin: Unify logging infrastructure --- .../src/Ide/Plugin/ExplicitFields.hs | 1 + plugins/hls-explicit-record-fields-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 1a32ae70bb..e67eafad22 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -11,6 +11,7 @@ module Ide.Plugin.ExplicitFields ( descriptor + , Log ) where import Control.Lens ((^.)) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index c31c45223b..2955c5bc4d 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -15,8 +15,8 @@ import Test.Hls main :: IO () main = defaultTestRunner test -plugin :: PluginDescriptor IdeState -plugin = ExplicitFields.descriptor mempty "explicit-fields" +plugin :: PluginTestDescriptor ExplicitFields.Log +plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" test :: TestTree test = testGroup "explicit-fields" From fc9215a2a388c521b76a9d6a6af409b529bc081a Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:51:25 +0100 Subject: [PATCH 17/32] hls-floskell-plugin: Unify logging infrastructure --- plugins/hls-floskell-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-floskell-plugin/test/Main.hs b/plugins/hls-floskell-plugin/test/Main.hs index 155291eec4..908139f377 100644 --- a/plugins/hls-floskell-plugin/test/Main.hs +++ b/plugins/hls-floskell-plugin/test/Main.hs @@ -10,8 +10,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -floskellPlugin :: PluginDescriptor IdeState -floskellPlugin = Floskell.descriptor "floskell" +floskellPlugin :: PluginTestDescriptor () +floskellPlugin = mkPluginTestDescriptor' Floskell.descriptor "floskell" tests :: TestTree tests = testGroup "floskell" From b8ebea597d2404d228dc1158e1bc3b3b4e6f5061 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:52:15 +0100 Subject: [PATCH 18/32] hls-fourmolu-plugin: Unify logging infrastructure --- plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs | 1 + plugins/hls-fourmolu-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 96c945386e..8dd8611397 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -9,6 +9,7 @@ module Ide.Plugin.Fourmolu ( descriptor, provider, + LogEvent, ) where import Control.Exception (IOException, try) diff --git a/plugins/hls-fourmolu-plugin/test/Main.hs b/plugins/hls-fourmolu-plugin/test/Main.hs index 872126f3a2..056003cc7e 100644 --- a/plugins/hls-fourmolu-plugin/test/Main.hs +++ b/plugins/hls-fourmolu-plugin/test/Main.hs @@ -15,8 +15,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -fourmoluPlugin :: PluginDescriptor IdeState -fourmoluPlugin = Fourmolu.descriptor mempty "fourmolu" +fourmoluPlugin :: PluginTestDescriptor Fourmolu.LogEvent +fourmoluPlugin = mkPluginTestDescriptor Fourmolu.descriptor "fourmolu" tests :: TestTree tests = From de0591d2ea76366d8f7cf8c244982f75f342596b Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:52:43 +0100 Subject: [PATCH 19/32] hls-gadt-plugin: Unify logging infrastructure --- plugins/hls-gadt-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-gadt-plugin/test/Main.hs b/plugins/hls-gadt-plugin/test/Main.hs index bcde384232..ec4f901736 100644 --- a/plugins/hls-gadt-plugin/test/Main.hs +++ b/plugins/hls-gadt-plugin/test/Main.hs @@ -15,8 +15,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -gadtPlugin :: PluginDescriptor IdeState -gadtPlugin = GADT.descriptor "GADT" +gadtPlugin :: PluginTestDescriptor () +gadtPlugin = mkPluginTestDescriptor' GADT.descriptor "GADT" tests :: TestTree tests = testGroup "GADT" From 1f84781f038cd0a97069e7791b6d195f9293c3df Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 16:54:45 +0100 Subject: [PATCH 20/32] hls-haddock-comments-plugin: Unify logging infrastructure --- .../src/Ide/Plugin/HaddockComments.hs | 2 +- plugins/hls-haddock-comments-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 66ea479416..2e9f4a5149 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.HaddockComments (descriptor) where +module Ide.Plugin.HaddockComments (descriptor, E.Log) where import Control.Monad (join, when) import Control.Monad.IO.Class diff --git a/plugins/hls-haddock-comments-plugin/test/Main.hs b/plugins/hls-haddock-comments-plugin/test/Main.hs index eaf10903a0..7df393abf6 100644 --- a/plugins/hls-haddock-comments-plugin/test/Main.hs +++ b/plugins/hls-haddock-comments-plugin/test/Main.hs @@ -18,8 +18,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -haddockCommentsPlugin :: PluginDescriptor IdeState -haddockCommentsPlugin = HaddockComments.descriptor mempty "haddockComments" +haddockCommentsPlugin :: PluginTestDescriptor HaddockComments.Log +haddockCommentsPlugin = mkPluginTestDescriptor HaddockComments.descriptor "haddockComments" tests :: TestTree tests = From 7b61c0252c099d71f91fdb297969b4d8f8a61b39 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:04:43 +0100 Subject: [PATCH 21/32] hls-hlint-plugin: Unify logging infrastructure --- plugins/hls-hlint-plugin/test/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index ee1ab380d6..966aa68655 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -24,8 +24,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -hlintPlugin :: PluginDescriptor IdeState -hlintPlugin = HLint.descriptor mempty "hlint" +hlintPlugin :: PluginTestDescriptor HLint.Log +hlintPlugin = mkPluginTestDescriptor HLint.descriptor "hlint" tests :: TestTree tests = testGroup "hlint" [ @@ -101,7 +101,7 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServer' [hlintPlugin] def def noLiteralCaps "test/testdata" $ do + , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps hlintPlugin noLiteralCaps "test/testdata" $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" From cebc673e7a9a705e920933c125729e03cd4eb42f Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:05:35 +0100 Subject: [PATCH 22/32] hls-module-name-plugin: Unify logging infrastructure --- plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs | 1 + plugins/hls-module-name-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index e2083b2114..d520da077e 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -14,6 +14,7 @@ Provide CodeLenses to: -} module Ide.Plugin.ModuleName ( descriptor, + Log, ) where import Control.Monad (forM_, void) diff --git a/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs index 914fcb69dd..06da6aefcf 100644 --- a/plugins/hls-module-name-plugin/test/Main.hs +++ b/plugins/hls-module-name-plugin/test/Main.hs @@ -12,8 +12,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -moduleNamePlugin :: PluginDescriptor IdeState -moduleNamePlugin = ModuleName.descriptor mempty "moduleName" +moduleNamePlugin :: PluginTestDescriptor ModuleName.Log +moduleNamePlugin = mkPluginTestDescriptor ModuleName.descriptor "moduleName" tests :: TestTree tests = From e349fc50aa9c3d00f3e3872607a3413f84887798 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:05:59 +0100 Subject: [PATCH 23/32] hls-ormolu-plugin: Unify logging infrastructure --- plugins/hls-ormolu-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-ormolu-plugin/test/Main.hs b/plugins/hls-ormolu-plugin/test/Main.hs index bc637bd4dc..f03b65719d 100644 --- a/plugins/hls-ormolu-plugin/test/Main.hs +++ b/plugins/hls-ormolu-plugin/test/Main.hs @@ -11,8 +11,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -ormoluPlugin :: PluginDescriptor IdeState -ormoluPlugin = Ormolu.descriptor "ormolu" +ormoluPlugin :: PluginTestDescriptor () +ormoluPlugin = mkPluginTestDescriptor' Ormolu.descriptor "ormolu" tests :: TestTree tests = testGroup "ormolu" From c18a8b2717d33a2399b1fbec942f2e4be9775406 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:06:27 +0100 Subject: [PATCH 24/32] hls-pragmas-plugin: Unify logging infrastructure --- plugins/hls-pragmas-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 0b5941a88a..4285062f05 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -15,8 +15,8 @@ import Test.Hls.Util (onlyWorkForGhcVersions) main :: IO () main = defaultTestRunner tests -pragmasPlugin :: PluginDescriptor IdeState -pragmasPlugin = descriptor "pragmas" +pragmasPlugin :: PluginTestDescriptor () +pragmasPlugin = mkPluginTestDescriptor' descriptor "pragmas" tests :: TestTree tests = From 37dc5dca83ea578d69f59a02b94b4cb22fd44170 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:07:34 +0100 Subject: [PATCH 25/32] hls-qualify-imported-names-plugin: Unify logging infrastructure --- .../hls-qualify-imported-names-plugin/test/Main.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/plugins/hls-qualify-imported-names-plugin/test/Main.hs b/plugins/hls-qualify-imported-names-plugin/test/Main.hs index 3f118ecc46..38409c218e 100644 --- a/plugins/hls-qualify-imported-names-plugin/test/Main.hs +++ b/plugins/hls-qualify-imported-names-plugin/test/Main.hs @@ -15,6 +15,7 @@ import Test.Hls (CodeAction (CodeAction, _title Command (Command), IdeState, MonadIO (liftIO), PluginDescriptor, + PluginTestDescriptor, Position (Position), Range (Range), Session, TestName, TestTree, @@ -23,8 +24,10 @@ import Test.Hls (CodeAction (CodeAction, _title defaultTestRunner, executeCodeAction, getCodeActions, - goldenWithHaskellDoc, openDoc, - rename, runSessionWithServer, + goldenWithHaskellDoc, + mkPluginTestDescriptor', + openDoc, rename, + runSessionWithServer, testCase, testGroup, type (|?) (InR), (@?=)) @@ -126,8 +129,8 @@ codeActionGoldenTest testCaseName goldenFilename point = testDataDir :: String testDataDir = "test" "data" -pluginDescriptor :: PluginDescriptor IdeState -pluginDescriptor = QualifyImportedNames.descriptor "qualifyImportedNames" +pluginDescriptor :: PluginTestDescriptor () +pluginDescriptor = mkPluginTestDescriptor' QualifyImportedNames.descriptor "qualifyImportedNames" getCodeActionTitle :: (Command |? CodeAction) -> Maybe Text getCodeActionTitle commandOrCodeAction From 23f3c6da9d74ae6237cc46ba17fb9d3c5cfbdfaa Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:13:23 +0100 Subject: [PATCH 26/32] hls-refactor-plugin: Unify logging infrastructure --- plugins/hls-refactor-plugin/test/Main.hs | 23 +++++++++++-------- .../test/Test/AddArgument.hs | 2 +- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index e1b9fe9de7..5d9baa0c21 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -64,14 +64,17 @@ import qualified Test.AddArgument main :: IO () main = defaultTestRunner tests -refactorPlugin :: [PluginDescriptor IdeState] -refactorPlugin = - [ Refactor.iePluginDescriptor mempty "ghcide-code-actions-imports-exports" - , Refactor.typeSigsPluginDescriptor mempty "ghcide-code-actions-type-signatures" - , Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings" - , Refactor.fillHolePluginDescriptor mempty "ghcide-code-actions-fill-holes" - , Refactor.extendImportPluginDescriptor mempty "ghcide-completions-1" - ] ++ GhcIde.descriptors mempty +refactorPlugin :: IO [PluginDescriptor IdeState] +refactorPlugin = do + exactprintLog <- pluginTestRecorder + ghcideLog <- pluginTestRecorder + pure $ + [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports" + , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures" + , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings" + , Refactor.fillHolePluginDescriptor exactprintLog "ghcide-code-actions-fill-holes" + , Refactor.extendImportPluginDescriptor exactprintLog "ghcide-completions-1" + ] ++ GhcIde.descriptors ghcideLog tests :: TestTree tests = @@ -3729,7 +3732,9 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir = runSessionWithServer' refactorPlugin def def lspTestCaps dir +runInDir dir act = do + plugin <- refactorPlugin + runSessionWithServer' plugin def def lspTestCaps dir act lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs index b52e39d511..7bd26224af 100644 --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -64,7 +64,7 @@ mkGoldenAddArgTest' testFileName range varName = do liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function") executeCodeAction action goldenWithHaskellDoc - (Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings") + (mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings") (testFileName <> " (golden)") "test/data/golden/add-arg" testFileName From 3c314178289e0e52c1ad00e64fd28c0e7e0c0f2a Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:13:53 +0100 Subject: [PATCH 27/32] hls-refine-imports-plugin: Unify logging infrastructure --- plugins/hls-refine-imports-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-refine-imports-plugin/test/Main.hs b/plugins/hls-refine-imports-plugin/test/Main.hs index bbd1ad6958..20df99f96a 100644 --- a/plugins/hls-refine-imports-plugin/test/Main.hs +++ b/plugins/hls-refine-imports-plugin/test/Main.hs @@ -23,8 +23,8 @@ main = defaultTestRunner $ , codeLensGoldenTest "UsualCase" 1 ] -refineImportsPlugin :: PluginDescriptor IdeState -refineImportsPlugin = RefineImports.descriptor mempty "refineImports" +refineImportsPlugin :: PluginTestDescriptor RefineImports.Log +refineImportsPlugin = mkPluginTestDescriptor RefineImports.descriptor "refineImports" -- code action tests From b49486af91b409cb754e3a5670e154417a008a89 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:14:24 +0100 Subject: [PATCH 28/32] hls-rename-plugin: Unify logging infrastructure --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 2 +- plugins/hls-rename-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index a752433e4a..bb3da0fe81 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -9,7 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Ide.Plugin.Rename (descriptor) where +module Ide.Plugin.Rename (descriptor, E.Log) where #if MIN_VERSION_ghc(9,2,1) import GHC.Parser.Annotation (AnnContext, AnnList, diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 5d662b1ad6..0896d9d5bb 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -12,8 +12,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -renamePlugin :: PluginDescriptor IdeState -renamePlugin = Rename.descriptor mempty "rename" +renamePlugin :: PluginTestDescriptor Rename.Log +renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename" -- See https://github.com/wz1000/HieDb/issues/45 recordConstructorIssue :: String From eda59c007ce6239717c3df8539a9d770f8f1a61e Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:15:19 +0100 Subject: [PATCH 29/32] hls-splice-plugin: Unify logging infrastructure --- plugins/hls-splice-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index a33d3b4211..492e68100c 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -21,8 +21,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -splicePlugin :: PluginDescriptor IdeState -splicePlugin = Splice.descriptor "splice" +splicePlugin :: PluginTestDescriptor () +splicePlugin = mkPluginTestDescriptor' Splice.descriptor "splice" tests :: TestTree tests = testGroup "splice" From 822671e0467726947273758a9b2593694ae21297 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:16:08 +0100 Subject: [PATCH 30/32] hls-stan-plugin: Unify logging infrastructure --- plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs | 2 +- plugins/hls-stan-plugin/test/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index db2f18b9ef..334c56a7cb 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -1,4 +1,4 @@ -module Ide.Plugin.Stan (descriptor) where +module Ide.Plugin.Stan (descriptor, Log) where import Control.DeepSeq (NFData) import Control.Monad (void) diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 3f6c5e9bad..48e9128329 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -38,8 +38,8 @@ tests = testDir :: FilePath testDir = "test/testdata" -stanPlugin :: PluginDescriptor IdeState -stanPlugin = Stan.descriptor mempty "stan" +stanPlugin :: PluginTestDescriptor Stan.Log +stanPlugin = mkPluginTestDescriptor Stan.descriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = From f2f11cae04accc5219d1e731bdddc45bd65eca11 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:16:29 +0100 Subject: [PATCH 31/32] hls-stylish-haskell-plugin: Unify logging infrastructure --- plugins/hls-stylish-haskell-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs index 236b705c42..bd6f55e9e6 100644 --- a/plugins/hls-stylish-haskell-plugin/test/Main.hs +++ b/plugins/hls-stylish-haskell-plugin/test/Main.hs @@ -10,8 +10,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -stylishHaskellPlugin :: PluginDescriptor IdeState -stylishHaskellPlugin = StylishHaskell.descriptor "stylishHaskell" +stylishHaskellPlugin :: PluginTestDescriptor () +stylishHaskellPlugin = mkPluginTestDescriptor' StylishHaskell.descriptor "stylishHaskell" tests :: TestTree tests = testGroup "stylish-haskell" From 1c4c1d16963663b42a0b83b791bd7fd6387c7fc4 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 26 Nov 2022 17:19:06 +0100 Subject: [PATCH 32/32] hls-tactics-plugin: Unify logging infrastructure --- plugins/hls-tactics-plugin/old/test/Utils.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs index db31d910cf..becc2ad3be 100644 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ b/plugins/hls-tactics-plugin/old/test/Utils.hs @@ -34,8 +34,8 @@ import Wingman.LanguageServer (mkShowMessageParams) import Wingman.Types -plugin :: PluginDescriptor IdeState -plugin = Tactic.descriptor mempty "tactics" +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor Tactic.descriptor "tactics" ------------------------------------------------------------------------------ -- | Get a range at the given line and column corresponding to having nothing @@ -61,13 +61,15 @@ resetGlobalHoleRef = writeIORef globalHoleRef 0 runSessionForTactics :: Session a -> IO a -runSessionForTactics = +runSessionForTactics act = do + recorder <- pluginTestRecorder runSessionWithServer' - [plugin] + [plugin recorder] def (def { messageTimeout = 20 } ) fullCaps tacticPath + act ------------------------------------------------------------------------------ -- | Make a tactic unit test.