ghcide-test-utils 1.9.0.0 → 2.0.0.0

raw patch · 3 files changed

+40/−52 lines, 3 filesdep +row-typesdep ~lsp-testPVP ok

version bump matches the API change (PVP)

Dependencies added: row-types

Dependency ranges changed: lsp-test

API changes (from Hackage documentation)

Files

• ghcide-test-utils.cabal +5/−14
• src/Development/IDE/Test.hs +26/−29
• src/Development/IDE/Test/Diagnostic.hs +9/−9

@@ -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

@@ -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 

@@ -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