diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index a9d3a595f3..4e5c25a9a1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -20,14 +20,18 @@ module Test.Hls goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, def, + -- * Running HLS for integration tests runSessionWithServer, + runSessionWithServerAndCaps, runSessionWithServerFormatter, runSessionWithCabalServerFormatter, runSessionWithServer', - waitForProgressDone, - waitForAllProgressDone, + -- * Helpful re-exports PluginDescriptor, IdeState, + -- * Assertion helper functions + waitForProgressDone, + waitForAllProgressDone, waitForBuildQueue, waitForTypecheck, waitForAction, @@ -35,6 +39,16 @@ 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(..), + Recorder, + Priority(..), ) where @@ -43,6 +57,7 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base import Control.Monad (guard, unless, void) +import Control.Monad.Extra (forM) import Control.Monad.IO.Class import Data.Aeson (Result (Success), Value (Null), fromJSON, @@ -62,7 +77,7 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Logger (Doc, Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), @@ -117,7 +132,8 @@ goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree goldenGitDiff name = goldenVsStringDiff name gitDiff goldenWithHaskellDoc - :: PluginDescriptor IdeState + :: Pretty b + => PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -128,7 +144,8 @@ goldenWithHaskellDoc goldenWithHaskellDoc = goldenWithDoc "haskell" goldenWithCabalDoc - :: PluginDescriptor IdeState + :: Pretty b + => PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -139,8 +156,9 @@ goldenWithCabalDoc goldenWithCabalDoc = goldenWithDoc "cabal" goldenWithDoc - :: T.Text - -> PluginDescriptor IdeState + :: Pretty b + => T.Text + -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -158,23 +176,119 @@ goldenWithDoc fileType plugin title testDataDir path desc ext act = act doc documentContents doc +-- ------------------------------------------------------------ +-- Helper function for initialising plugins under test +-- ------------------------------------------------------------ + +-- | Plugin under test where a fitting recorder is injected. +type PluginTestDescriptor b = Recorder (WithPriority b) -> PluginDescriptor IdeState + +-- | Wrap a plugin you want to test, and inject a fitting recorder as required. +-- +-- If you want to write the logs to stderr, run your tests with +-- "HLS_TEST_PLUGIN_LOG_STDERR=1", e.g. +-- +-- @ +-- HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test +-- @ +-- +-- +-- 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 + + Recorder {logger_} = docWithFilteredPriorityRecorder + + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) -runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a -runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps +-- ------------------------------------------------------------ +-- Run an HLS server testing a specific plugin +-- ------------------------------------------------------------ -runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithServerFormatter plugin formatter conf = +runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a +runSessionWithServer plugin fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' [plugin recorder] def def fullCaps fp act + +runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithServerAndCaps plugin caps fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' [plugin recorder] def def caps fp act + +runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a +runSessionWithServerFormatter plugin formatter conf fp act = do + recorder <- pluginTestRecorder runSessionWithServer' - [plugin] + [plugin recorder] def { formattingProvider = T.pack formatter , plugins = M.singleton (T.pack formatter) conf } def fullCaps + fp + act goldenWithHaskellDocFormatter - :: PluginDescriptor IdeState -- ^ Formatter plugin to be used + :: Pretty b + => PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test @@ -195,7 +309,8 @@ goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc documentContents doc goldenWithCabalDocFormatter - :: PluginDescriptor IdeState -- ^ Formatter plugin to be used + :: Pretty b + => PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test @@ -215,16 +330,18 @@ goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ex act doc documentContents doc -runSessionWithCabalServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithCabalServerFormatter plugin formatter conf = +runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a +runSessionWithCabalServerFormatter plugin formatter conf fp act = do + recorder <- pluginTestRecorder runSessionWithServer' - [plugin] + [plugin recorder] def { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (T.pack formatter) conf } def fullCaps + fp act -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a @@ -235,11 +352,13 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock - -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ runSessionWithServer' :: - -- | plugins to load on the server + -- | Plugins to load on the server. + -- + -- For improved logging, make sure these plugins have been initalised with + -- the recorder produced by @pluginTestRecorder@. [PluginDescriptor IdeState] -> -- | lsp config for the server Config -> @@ -253,20 +372,19 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug - - logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before, + -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it + -- uses a more descriptive name. + -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR". + -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins + -- under test. + (recorder, logger_) <- initialiseTestRecorder + ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] let - docWithFilteredPriorityRecorder@Recorder{ logger_ } = - if logStdErr == "0" then mempty - else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder - -- exists until old logging style is phased out logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins = diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index d6b19d4e7b..e3fa6607d5 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 :: 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 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" diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs index 35d6fe6ba8..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 :: PluginDescriptor IdeState -cabalFmtPlugin = CabalFmt.descriptor mempty "cabal-fmt" +cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log +cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt" tests :: CabalFmtFound -> TestTree tests found = testGroup "cabal-fmt" 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" 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/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/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 585f49143e..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 <- makeDefaultStderrRecorder Nothing Debug - defaultTestRunner . tests $ contramap (fmap pretty) 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 diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 5ad43de5f2..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 <- contramap (fmap pretty) <$> makeDefaultStderrRecorder Nothing Debug 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 diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index cc2baa3ac6..df9c83b4ac 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -29,8 +29,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -evalPlugin :: PluginDescriptor IdeState -evalPlugin = Eval.descriptor mempty "eval" +evalPlugin :: PluginTestDescriptor Eval.Log +evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval" tests :: TestTree tests = 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 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" 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 b77281f05a..e2bf77265d 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" 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" 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 = 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" 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 = 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" 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 = 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" 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 = 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 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 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 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 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" 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 = 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" 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. diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 6fe2e4ef24..21f1ec4e9b 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 @@ -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: @@ -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" :