diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,13 +41,13 @@ , directory , extra , filepath - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.1 + , hls-plugin-api == 2.1.0.0 , lens - , lsp ^>=1.6.0.0 - , lsp-test ^>=0.14 - , lsp-types ^>=1.6.0.0 + , lsp ^>=2.1.0.0 + , lsp-test ^>=0.15.0.1 + , lsp-types ^>=2.0.1.0 , tasty , tasty-expected-failure , tasty-golden @@ -56,7 +56,7 @@ , temporary , text , unordered-containers - + , row-types ghc-options: -Wall if flag(pedantic) diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -1,21 +1,26 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, module Test.Tasty.ExpectedFailure, module Test.Hls.Util, - module Language.LSP.Types, + module Language.LSP.Protocol.Types, + module Language.LSP.Protocol.Message, module Language.LSP.Test, module Control.Monad.IO.Class, module Control.Applicative.Combinators, defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc, + goldenWithHaskellAndCaps, goldenWithCabalDoc, goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, @@ -53,62 +58,63 @@ where import Control.Applicative.Combinators -import Control.Concurrent.Async (async, cancel, wait) +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.Lens.Extras (is) +import Control.Monad (guard, unless, void) +import Control.Monad.Extra (forM) import Control.Monad.IO.Class -import Data.Aeson (Result (Success), - Value (Null), fromJSON, - toJSON) -import qualified Data.Aeson as A -import Data.ByteString.Lazy (ByteString) -import Data.Default (def) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState) -import Development.IDE.Main hiding (Log) -import qualified Development.IDE.Main as Ghcide -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 (Doc, Logger (Logger), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - makeDefaultStderrRecorder) +import Data.Aeson (Result (Success), + Value (Null), fromJSON, + toJSON) +import qualified Data.Aeson as A +import Data.ByteString.Lazy (ByteString) +import Data.Default (def) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE (IdeState) +import Development.IDE.Main hiding (Log) +import qualified Development.IDE.Main as Ghcide +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.Options import GHC.IO.Handle -import GHC.Stack (emptyCallStack) +import GHC.Stack (emptyCallStack) +import GHC.TypeLits +import Ide.Logger (Doc, Logger (Logger), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) import Ide.Types +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities (ClientCapabilities) -import Prelude hiding (log) -import System.Directory (getCurrentDirectory, - setCurrentDirectory) -import System.Environment (lookupEnv) +import Prelude hiding (log) +import System.Directory (getCurrentDirectory, + setCurrentDirectory) +import System.Environment (lookupEnv) import System.FilePath -import System.IO.Unsafe (unsafePerformIO) -import System.Process.Extra (createPipe) +import System.IO.Unsafe (unsafePerformIO) +import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util -import Test.Tasty hiding (Timeout) +import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -import Test.Tasty.Runners (NumThreads (..)) +import Test.Tasty.Runners (NumThreads (..)) newtype Log = LogIDEMain IDEMain.Log @@ -138,6 +144,27 @@ -> TestTree goldenWithHaskellDoc = goldenWithDoc "haskell" +goldenWithHaskellAndCaps + :: Pretty b + => ClientCapabilities + -> PluginTestDescriptor b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithHaskellAndCaps clientCaps plugin title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServerAndCaps plugin clientCaps testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + goldenWithCabalDoc :: Pretty b => PluginTestDescriptor b @@ -415,7 +442,7 @@ -- | Wait for the next progress end step waitForProgressDone :: Session () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v-> Just () _ -> Nothing -- | Wait for all progress to be done @@ -425,7 +452,7 @@ where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -433,23 +460,23 @@ -- | Wait for the build queue to be empty waitForBuildQueue :: Session Seconds waitForBuildQueue = do - let m = SCustomMethod "test" + let m = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest m (toJSON WaitForShakeQueue) (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of - ResponseMessage{_result=Right Null} -> return td + TResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method - _ -> return 0 + _ -> return 0 callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) callTestPlugin cmd = do - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ do e <- _result case A.fromJSON e of - A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing + A.Error err -> Left $ ResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing A.Success a -> pure a waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) @@ -464,7 +491,7 @@ sendConfigurationChanged :: Value -> Session () sendConfigurationChanged config = - sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone @@ -473,14 +500,14 @@ waitForKickStart = void $ skipManyTill anyMessage nonTrivialKickStart nonTrivialKickDone :: Session () -nonTrivialKickDone = kick "done" >>= guard . not . null +nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session () -nonTrivialKickStart = kick "start" >>= guard . not . null +nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null -kick :: T.Text -> Session [FilePath] -kick msg = do - NotMess NotificationMessage{_params} <- customNotification $ "kick/" <> msg +kick :: KnownSymbol k => Proxy k -> Session [FilePath] +kick proxyMsg = do + NotMess TNotificationMessage{_params} <- customNotification proxyMsg case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs --- a/src/Test/Hls/Util.hs +++ b/src/Test/Hls/Util.hs @@ -5,9 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} module Test.Hls.Util ( -- * Test Capabilities - codeActionSupportCaps + codeActionResolveCaps + , codeActionNoResolveCaps + , codeActionSupportCaps , expectCodeAction -- * Environment specifications -- for ignoring tests @@ -48,21 +53,22 @@ import Control.Applicative.Combinators (skipManyTill, (<|>)) import Control.Exception (catch, throwIO) -import Control.Lens ((&), (?~), (^.)) +import Control.Lens ((&), (?~), (^.), _Just, (.~)) import Control.Monad import Control.Monad.IO.Class import qualified Data.Aeson as A import Data.Bool (bool) import Data.Default +import Data.Row +import Data.Proxy import Data.List.Extra (find) import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE (GhcVersion (..), ghcVersion) import qualified Language.LSP.Test as Test -import Language.LSP.Types hiding (Reason (..)) -import qualified Language.LSP.Types.Capabilities as C -import Language.LSP.Types.Lens (textDocument) -import qualified Language.LSP.Types.Lens as L +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as L import System.Directory import System.FilePath import System.Info.Extra (isMac, isWindows) @@ -75,19 +81,28 @@ import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) -noLiteralCaps :: C.ClientCapabilities -noLiteralCaps = def & textDocument ?~ textDocumentCaps +noLiteralCaps :: ClientCapabilities +noLiteralCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing -codeActionSupportCaps :: C.ClientCapabilities -codeActionSupportCaps = def & textDocument ?~ textDocumentCaps +codeActionSupportCaps :: ClientCapabilities +codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing - literalSupport = CodeActionLiteralSupport def + literalSupport = #codeActionKind .== (#valueSet .== []) +codeActionResolveCaps :: ClientCapabilities +codeActionResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"]) + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True + +codeActionNoResolveCaps :: ClientCapabilities +codeActionNoResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- --------------------------------------------------------------------- @@ -243,8 +258,8 @@ waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) - let (List diags) = diagsNot ^. L.params . L.diagnostics + diagsNot <- skipManyTill Test.anyMessage (Test.message SMethod_TextDocumentPublishDiagnostics) + let diags = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc else return diags @@ -272,22 +287,22 @@ -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - testId <- Test.sendRequest (SCustomMethod "test") A.Null + testId <- Test.sendRequest (SMethod_CustomMethod (Proxy @"test")) A.Null handleMessages testId where matches :: Diagnostic -> Bool matches d = d ^. L.source == Just (T.pack source) - handleMessages testId = handleDiagnostic testId <|> handleCustomMethodResponse testId <|> ignoreOthers testId + handleMessages testId = handleDiagnostic testId <|> handleMethod_CustomMethodResponse testId <|> ignoreOthers testId handleDiagnostic testId = do - diagsNot <- Test.message STextDocumentPublishDiagnostics + diagsNot <- Test.message SMethod_TextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri - (List diags) = diagsNot ^. L.params . L.diagnostics + ( diags) = diagsNot ^. L.params . L.diagnostics res = filter matches diags if fileUri == document ^. L.uri && not (null res) then return res else handleMessages testId - handleCustomMethodResponse testId = do - _ <- Test.responseForId (SCustomMethod "test") testId + handleMethod_CustomMethodResponse testId = do + _ <- Test.responseForId (SMethod_CustomMethod (Proxy @"test")) testId pure [] ignoreOthers testId = void Test.anyMessage >> handleMessages testId