diff --git a/ghcide-test-utils.cabal b/ghcide-test-utils.cabal --- a/ghcide-test-utils.cabal +++ b/ghcide-test-utils.cabal @@ -3,7 +3,7 @@ build-type: Simple category: Development name: ghcide-test-utils -version: 1.9.0.0 +version: 2.0.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -14,7 +14,7 @@ Test utils for ghcide homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 +tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.4 || == 9.8.1 source-repository head type: git @@ -22,7 +22,7 @@ library - default-language: Haskell2010 + default-language: GHC2021 build-depends: aeson, base > 4.9 && < 5, @@ -35,25 +35,16 @@ lsp-types, hls-plugin-api, lens, - lsp-test ^>= 0.14, + lsp-test ^>= 0.16, tasty-hunit >= 0.10, text, + row-types, hs-source-dirs: src exposed-modules: Development.IDE.Test Development.IDE.Test.Diagnostic default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving LambdaCase - NamedFieldPuns OverloadedStrings RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications ViewPatterns diff --git a/src/Development/IDE/Test.hs b/src/Development/IDE/Test.hs --- a/src/Development/IDE/Test.hs +++ b/src/Development/IDE/Test.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} module Development.IDE.Test ( Cursor @@ -43,20 +42,20 @@ import Data.Default import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic +import GHC.TypeLits (symbolVal) import Ide.Plugin.Config (CheckParents, checkProject) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) import System.FilePath (equalFilePath) import System.Time.Extra @@ -75,23 +74,23 @@ -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = - expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics - unless (actual == List []) $ liftIO $ + expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do + let fileUri = diagsNot ^. L.params . L.uri + actual = diagsNot ^. L.params . L.diagnostics + unless (actual == []) $ liftIO $ assertFailure $ "Got unexpected diagnostics for " <> show fileUri <> " got " <> show actual -expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session () expectMessages m timeout handle = do -- Give any further diagnostic messages time to arrive. liftIO $ sleep timeout -- 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. - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount go cm i where @@ -102,7 +101,7 @@ flushMessages :: Session () flushMessages = do - let cm = SCustomMethod "non-existent-method" + let cm = SMethod_CustomMethod (Proxy @"non-existent-method") i <- sendRequest cm A.Null void (responseForId cm i) <|> ignoreOthers cm i where @@ -118,8 +117,8 @@ = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) +unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do @@ -130,13 +129,13 @@ expectDiagnosticsWithTags' :: (HasCallStack, MonadIO m) => - m (Uri, List Diagnostic) -> + m (Uri, [Diagnostic]) -> Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> m () expectDiagnosticsWithTags' next m | null m = do (_,actual) <- next case actual of - List [] -> + [] -> return () _ -> liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual @@ -178,19 +177,19 @@ checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' + expectDiagnosticsWithTags' (return (_uri, obtained)) expected' canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) -diagnostic = LspTest.message STextDocumentPublishDiagnostics +diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) tryCallTestPlugin 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 $ case _result of Left e -> Left e Right json -> case A.fromJSON json of @@ -230,8 +229,8 @@ waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res waitForCustomMessage msg pred = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) - | lbl == msg -> pred value + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value}) + | symbolVal p == T.unpack msg -> pred value _ -> Nothing waitForGC :: Session [T.Text] @@ -241,10 +240,7 @@ _ -> Nothing configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) +configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject}) -- | Pattern match a message from ghcide indicating that a file has been indexed isReferenceReady :: FilePath -> Session () @@ -252,9 +248,10 @@ referenceReady :: (FilePath -> Bool) -> Session FilePath referenceReady pred = satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params}) + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) | A.Success fp <- A.fromJSON _params , pred fp + , symbolVal p == "ghcide/reference/ready" -> Just fp _ -> Nothing diff --git a/src/Development/IDE/Test/Diagnostic.hs b/src/Development/IDE/Test/Diagnostic.hs --- a/src/Development/IDE/Test/Diagnostic.hs +++ b/src/Development/IDE/Test/Diagnostic.hs @@ -1,10 +1,10 @@ module Development.IDE.Test.Diagnostic where -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp +import Control.Lens ((^.)) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Types -- | (0-based line number, 0-based column number) type Cursor = (UInt, UInt) @@ -33,10 +33,10 @@ standardizeQuotes (T.toLower $ d ^. message) && hasTag expectedTag (d ^. tags) - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just tags) = actualTag `elem` tags standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let