hls-test-utils 1.3.0.0 → 1.4.0.0

raw patch · 3 files changed

+93/−84 lines, 3 filesdep ~ghcidedep ~hls-plugin-apidep ~lspPVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +5/−5
• src/Test/Hls.hs +44/−44
• src/Test/Hls/Util.hs +44/−35

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-test-utils-version:       1.3.0.0+version:       1.4.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                  ^>=1.6 || ^>=1.7+    , ghcide                  ^>=1.8     , hls-graph-    , hls-plugin-api          ^>=1.3 || ^>=1.4+    , hls-plugin-api          ^>=1.5     , lens-    , lsp                     ^>=1.4+    , lsp                     ^>=1.6.0.0     , lsp-test                ^>=0.14-    , lsp-types               ^>=1.4.0.1+    , lsp-types               ^>=1.6.0.0     , tasty     , tasty-expected-failure     , tasty-golden

@@ -47,8 +47,8 @@ import qualified Data.Aeson                      as A import           Data.ByteString.Lazy            (ByteString) import           Data.Default                    (def)-import           Data.Maybe                      (fromMaybe) 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@@ -69,7 +69,8 @@ import           Development.IDE.Types.Options import           GHC.IO.Handle import           GHC.Stack                       (emptyCallStack)-import           Ide.Plugin.Config               (Config, formattingProvider, PluginConfig, plugins)+import           Ide.Plugin.Config               (Config, PluginConfig,+                                                  formattingProvider, plugins) import           Ide.PluginUtils                 (idePluginsToPluginDesc,                                                   pluginDescToIdePlugins) import           Ide.Types@@ -188,57 +189,56 @@   Session a ->   IO a runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do-  (inR, inW) <- createPipe-  (outR, outW) <- createPipe+    (inR, inW) <- createPipe+    (outR, outW) <- createPipe -  docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug+    docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug -  logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR"+    logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" -  let-    docWithFilteredPriorityRecorder@Recorder{ logger_ } =-      if logStdErr == "0" then mempty-      else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder+    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))+        -- exists until old logging style is phased out+        logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) -    recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder+        recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder -    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger+        arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger -    hlsPlugins =-      idePluginsToPluginDesc argsHlsPlugins-      ++ [Test.blockCommandDescriptor "block-command", Test.plugin]-      ++ plugins-    ideOptions = \config ghcSession ->-      let defIdeOptions = argsIdeOptions config ghcSession-      in defIdeOptions-           { optTesting = IdeTesting True-           , optCheckProject = pure False-           }+        hlsPlugins =+            plugins+            ++ [Test.blockCommandDescriptor "block-command", Test.plugin]+            ++ idePluginsToPluginDesc argsHlsPlugins+        ideOptions config ghcSession =+            let defIdeOptions = argsIdeOptions config ghcSession+            in defIdeOptions+                    { optTesting = IdeTesting True+                    , optCheckProject = pure False+                    } -  server <--    async $-      Ghcide.defaultMain-        (cmapWithPrio LogIDEMain recorder)-        arguments-          { argsHandleIn = pure inR-          , argsHandleOut = pure outW-          , argsDefaultHlsConfig = conf-          , argsLogger = argsLogger-          , argsIdeOptions = ideOptions-          , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins }+    server <- async $+        Ghcide.defaultMain (cmapWithPrio LogIDEMain recorder)+            arguments+                { argsHandleIn = pure inR+                , argsHandleOut = pure outW+                , argsDefaultHlsConfig = conf+                , argsLogger = argsLogger+                , argsIdeOptions = ideOptions+                , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins+                } -  x <- runSessionWithHandles inW outR sconf caps root s-  hClose inW-  timeout 3 (wait server) >>= \case-    Just () -> pure ()-    Nothing -> do-      putStrLn "Server does not exit in 3s, canceling the async task..."-      (t, _) <- duration $ cancel server-      putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"-  pure x+    x <- runSessionWithHandles inW outR sconf caps root s+    hClose inW+    timeout 3 (wait server) >>= \case+        Just () -> pure ()+        Nothing -> do+            putStrLn "Server does not exit in 3s, canceling the async task..."+            (t, _) <- duration $ cancel server+            putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"+    pure x  -- | Wait for the next progress end step waitForProgressDone :: Session ()

@@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeOperators         #-} module Test.Hls.Util@@ -25,12 +24,14 @@     , noLiteralCaps     , ignoreForGhcVersions     , ignoreInEnv+    , onlyRunForGhcVersions     , inspectCodeAction     , inspectCommand     , inspectDiagnostic     , knownBrokenOnWindows     , knownBrokenForGhcVersions     , knownBrokenInEnv+    , onlyWorkForGhcVersions     , setupBuildToolFiles     , SymbolLocation     , waitForDiagnosticsFrom@@ -38,12 +39,13 @@     , waitForDiagnosticsFromSourceWithTimeout     , withCurrentDirectoryInTmp     , withCurrentDirectoryInTmp'+    , withCanonicalTempDir   ) where  import           Control.Applicative.Combinators (skipManyTill, (<|>)) import           Control.Exception               (catch, throwIO)-import           Control.Lens                    ((^.))+import           Control.Lens                    ((&), (?~), (^.)) import           Control.Monad import           Control.Monad.IO.Class import qualified Data.Aeson                      as A@@ -52,16 +54,18 @@ import           Data.List.Extra                 (find) import qualified Data.Set                        as Set import qualified Data.Text                       as T-import           Development.IDE                 (GhcVersion(..), ghcVersion)+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           System.Directory import           System.Environment import           System.FilePath-import           System.IO.Temp import           System.Info.Extra               (isMac, isWindows)+import qualified System.IO.Extra+import           System.IO.Temp import           System.Time.Extra               (Seconds, sleep) import           Test.Tasty                      (TestTree) import           Test.Tasty.ExpectedFailure      (expectFailBecause,@@ -70,13 +74,13 @@                                                   (@?=))  noLiteralCaps :: C.ClientCapabilities-noLiteralCaps = def { C._textDocument = Just textDocumentCaps }+noLiteralCaps = def & textDocument ?~ textDocumentCaps   where     textDocumentCaps = def { C._codeAction = Just codeActionCaps }     codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing  codeActionSupportCaps :: C.ClientCapabilities-codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps }+codeActionSupportCaps = def & textDocument ?~ textDocumentCaps   where     textDocumentCaps = def { C._codeAction = Just codeActionCaps }     codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing@@ -148,6 +152,20 @@ ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree ignoreForGhcVersions vers = ignoreInEnv (map GhcVer vers) +-- | Mark as broken if GHC does not match only work versions.+onlyWorkForGhcVersions :: (GhcVersion -> Bool) -> String -> TestTree -> TestTree+onlyWorkForGhcVersions p reason =+    if p ghcVersion+        then id+        else expectFailBecause reason++-- | Ignore the test if GHC does not match only work versions.+onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree+onlyRunForGhcVersions vers =+    if ghcVersion `elem` vers+    then const id+    else ignoreTestBecause+ -- ---------------------------------------------------------------------  hieYamlCradleDirectContents :: String@@ -237,7 +255,7 @@ onMatch as predicate err = maybe (fail err) return (find predicate as)  noMatch :: [a] -> (a -> Bool) -> String -> IO ()-noMatch [] _ _ = pure ()+noMatch [] _ _           = pure () noMatch as predicate err = bool (pure ()) (fail err) (any predicate as)  inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic@@ -279,16 +297,7 @@        else return diags  waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic]-waitForDiagnosticsFromSource doc src = do-    diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics)-    let (List diags) = diagsNot ^. L.params . L.diagnostics-    let res = filter matches diags-    if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res-       then waitForDiagnosticsFromSource doc src-       else return res-  where-    matches :: Diagnostic -> Bool-    matches d = d ^. L.source == Just (T.pack src)+waitForDiagnosticsFromSource = waitForDiagnosticsFromSourceWithTimeout 5  -- | wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period@@ -304,38 +313,31 @@ -- If timeout is 0 it will wait until the session timeout waitForDiagnosticsFromSourceWithTimeout :: Seconds -> TextDocumentIdentifier -> String -> Test.Session [Diagnostic] waitForDiagnosticsFromSourceWithTimeout timeout document source = do-    when (timeout > 0) $ do+    when (timeout > 0) $         -- 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.-        void $ Test.sendNotification (SCustomMethod "non-existent-method") A.Null-    handleMessages+    testId <- Test.sendRequest (SCustomMethod "test") A.Null+    handleMessages testId   where     matches :: Diagnostic -> Bool     matches d = d ^. L.source == Just (T.pack source) -    handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers-    handleDiagnostic = do+    handleMessages testId = handleDiagnostic testId <|> handleCustomMethodResponse testId <|> ignoreOthers testId+    handleDiagnostic testId = do         diagsNot <- Test.message STextDocumentPublishDiagnostics         let fileUri = diagsNot ^. L.params . L.uri             (List diags) = diagsNot ^. L.params . L.diagnostics             res = filter matches diags         if fileUri == document ^. L.uri && not (null res)-            then return diags else handleMessages-    handleCustomMethodResponse =-        -- the CustomClientMethod triggers a RspCustomServer-        -- handle that and then exit-        void (Test.satisfyMaybe responseForNonExistentMethod) >> return []--    responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage-    responseForNonExistentMethod notif-        | FromServerMess SWindowLogMessage logMsg <- notif,-          "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message)  = Just notif-        | otherwise = Nothing+            then return res else handleMessages testId+    handleCustomMethodResponse testId = do+        _ <- Test.responseForId (SCustomMethod "test") testId+        pure [] -    ignoreOthers = void Test.anyMessage >> handleMessages+    ignoreOthers testId = void Test.anyMessage >> handleMessages testId  failIfSessionTimeout :: IO a -> IO a failIfSessionTimeout action = action `catch` errorHandler@@ -362,9 +364,16 @@  -- --------------------------------------------------------------------- getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem-getCompletionByLabel desiredLabel compls = +getCompletionByLabel desiredLabel compls =     case find (\c -> c ^. L.label == desiredLabel) compls of         Just c -> pure c         Nothing -> liftIO . assertFailure $             "Completion with label " <> show desiredLabel             <> " not found in " <> show (fmap (^. L.label) compls)++-- ---------------------------------------------------------------------+-- Run with a canonicalized temp dir+withCanonicalTempDir :: (FilePath -> IO a) -> IO a+withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do+  dir' <- canonicalizePath dir+  f dir'