hls-test-utils 2.0.0.1 → 2.1.0.0

raw patch · 3 files changed

+127/−85 lines, 3 filesdep +row-typesdep ~ghcidedep ~hls-plugin-apidep ~lspPVP ok

version bump matches the API change (PVP)

Dependencies added: row-types

Dependency ranges changed: ghcide, hls-plugin-api, lsp, lsp-test, lsp-types

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +7/−7
• src/Test/Hls.hs +84/−57
• src/Test/Hls/Util.hs +36/−21

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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)

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

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