hls-test-utils (empty) → 1.0.0.0
raw patch · 4 files changed
+822/−0 lines, 4 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, blaze-markup, bytestring, containers, data-default, directory, extra, filepath, ghcide, hls-plugin-api, hspec, hspec-core, lens, lsp, lsp-test, lsp-types, shake, tasty, tasty-expected-failure, tasty-golden, tasty-hunit, tasty-rerun, temporary, text, unordered-containers
Files
- LICENSE +201/−0
- hls-test-utils.cabal +67/−0
- src/Test/Hls.hs +136/−0
- src/Test/Hls/Util.hs +418/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ hls-test-utils.cabal view
@@ -0,0 +1,67 @@+cabal-version: 2.4+name: hls-test-utils+version: 1.0.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>++homepage: https://github.com/haskell/haskell-language-server#readme+bug-reports: https://github.com/haskell/haskell-language-server/issues+license: Apache-2.0+license-file: LICENSE+author: The Haskell IDE Team+maintainer: alan.zimm@gmail.com+copyright: The Haskell IDE Team+category: Development+build-type: Simple++flag pedantic+ description: Enable -Werror+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/haskell/haskell-language-server++library+ exposed-modules:+ Test.Hls+ Test.Hls.Util++ hs-source-dirs: src+ build-depends:+ , aeson+ , async+ , base >=4.12 && <5+ , blaze-markup+ , bytestring+ , containers+ , data-default+ , directory+ , extra+ , filepath+ , ghcide ^>=1.2+ , hls-plugin-api ^>=1.1+ , hspec+ , hspec-core+ , lens+ , lsp ^>=1.2+ , lsp-test ==0.14.0.0+ , lsp-types ^>=1.2+ , shake+ , tasty+ , tasty-expected-failure+ , tasty-golden+ , tasty-hunit+ , tasty-rerun+ , temporary+ , text+ , unordered-containers++ ghc-options: -Wall++ if flag(pedantic)+ ghc-options: -Werror++ default-language: Haskell2010
+ src/Test/Hls.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE LambdaCase #-}+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.Test,+ module Control.Monad.IO.Class,+ module Control.Applicative.Combinators,+ defaultTestRunner,+ goldenGitDiff,+ def,+ runSessionWithServer,+ runSessionWithServerFormatter,+ runSessionWithServer',+ PluginDescriptor,+ IdeState,+ )+where++import Control.Applicative.Combinators+import Control.Concurrent.Async (async, cancel, wait)+import Control.Concurrent.Extra+import Control.Exception.Base+import Control.Monad.IO.Class+import Data.ByteString.Lazy (ByteString)+import Data.Default (def)+import qualified Data.Text as T+import Development.IDE (IdeState, hDuplicateTo',+ noLogging)+import Development.IDE.Main+import qualified Development.IDE.Main as Ghcide+import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide+import Development.IDE.Types.Options+import Development.Shake (ShakeOptions (shakeThreads))+import GHC.IO.Handle+import Ide.Plugin.Config (Config, formattingProvider)+import Ide.PluginUtils (pluginDescToIdePlugins)+import Ide.Types+import Language.LSP.Test+import Language.LSP.Types+import Language.LSP.Types.Capabilities (ClientCapabilities)+import System.Directory (getCurrentDirectory,+ setCurrentDirectory)+import System.IO.Extra+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.ExpectedFailure+import Test.Tasty.Golden+import Test.Tasty.HUnit+import Test.Tasty.Ingredients.Rerun++-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes+defaultTestRunner :: TestTree -> IO ()+defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000)++gitDiff :: FilePath -> FilePath -> [String]+gitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]++goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree+goldenGitDiff name = goldenVsStringDiff name gitDiff++runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a+runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps++runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a+runSessionWithServerFormatter plugin formatter =+ runSessionWithServer'+ [plugin]+ def {formattingProvider = T.pack formatter}+ def+ fullCaps++-- | Run an action, with stderr silenced+silenceStderr :: IO a -> IO a+silenceStderr action = withTempFile $ \temp ->+ bracket (openFile temp ReadWriteMode) hClose $ \h -> do+ old <- hDuplicate stderr+ buf <- hGetBuffering stderr+ h `hDuplicateTo'` stderr+ action `finally` do+ old `hDuplicateTo'` stderr+ hSetBuffering stderr buf+ hClose old++-- | Restore cwd after running an action+keepCurrentDirectory :: IO a -> IO a+keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const++{-# NOINLINE lock #-}+-- | Never run in parallel+lock :: Lock+lock = unsafePerformIO newLock++-- | Host a server, and run a test session on it+-- Note: cwd will be shifted into @root@ in @Session a@+runSessionWithServer' ::+ -- | plugins to load on the server+ [PluginDescriptor IdeState] ->+ -- | lsp config for the server+ Config ->+ -- | config for the test session+ SessionConfig ->+ ClientCapabilities ->+ FilePath ->+ Session a ->+ IO a+runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ silenceStderr $ do+ (inR, inW) <- createPipe+ (outR, outW) <- createPipe+ server <-+ async $+ Ghcide.defaultMain+ def+ { argsHandleIn = pure inR,+ argsHandleOut = pure outW,+ argsDefaultHlsConfig = conf,+ argsLogger = pure noLogging,+ argsIdeOptions = \config sessionLoader ->+ let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True}+ in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}},+ argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ Ghcide.descriptors+ }+ 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
+ src/Test/Hls/Util.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses, DuplicateRecordFields, TypeOperators, GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.Hls.Util+ (+ codeActionSupportCaps+ , expectCodeAction+ , expectDiagnostic+ , expectNoMoreDiagnostics+ , expectSameLocations+ , failIfSessionTimeout+ , flushStackEnvironment+ , fromAction+ , fromCommand+ , getHspecFormattedConfig+ , ghcVersion, GhcVersion(..)+ , hostOS, OS(..)+ , matchesCurrentEnv, EnvSpec(..)+ , ignoreForGhcVersions+ , ignoreInEnv+ , inspectCodeAction+ , inspectCommand+ , inspectDiagnostic+ , knownBrokenOnWindows+ , knownBrokenForGhcVersions+ , knownBrokenInEnv+ , setupBuildToolFiles+ , SymbolLocation+ , waitForDiagnosticsFrom+ , waitForDiagnosticsFromSource+ , waitForDiagnosticsFromSourceWithTimeout+ , withCurrentDirectoryInTmp+ )+where++import qualified Data.Aeson as A+import Control.Exception (throwIO, catch)+import Control.Monad+import Control.Monad.IO.Class+import Control.Applicative.Combinators (skipManyTill, (<|>))+import Control.Lens ((^.))+import Data.Default+import Data.List (intercalate)+import Data.List.Extra (find)+import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Text as T+import Language.LSP.Types hiding (Reason(..))+import qualified Language.LSP.Test as Test+import qualified Language.LSP.Types.Lens as L+import qualified Language.LSP.Types.Capabilities as C+import System.Directory+import System.Environment+import System.Time.Extra (Seconds, sleep)+import System.FilePath+import System.IO.Temp+import Test.Hspec.Runner+import Test.Hspec.Core.Formatters hiding (Seconds)+import Test.Tasty (TestTree)+import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause)+import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))+import Text.Blaze.Renderer.String (renderMarkup)+import Text.Blaze.Internal hiding (null)+import System.Info.Extra (isWindows, isMac)++codeActionSupportCaps :: C.ClientCapabilities+codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps }+ where+ textDocumentCaps = def { C._codeAction = Just codeActionCaps }+ codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing+ literalSupport = CodeActionLiteralSupport def++-- ---------------------------------------------------------------------++setupBuildToolFiles :: IO ()+setupBuildToolFiles = do+ forM_ files setupDirectFilesIn++setupDirectFilesIn :: FilePath -> IO ()+setupDirectFilesIn f =+ writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents+++-- ---------------------------------------------------------------------++files :: [FilePath]+files =+ [ "./test/testdata/"+ -- , "./test/testdata/addPackageTest/cabal-exe/"+ -- , "./test/testdata/addPackageTest/hpack-exe/"+ -- , "./test/testdata/addPackageTest/cabal-lib/"+ -- , "./test/testdata/addPackageTest/hpack-lib/"+ -- , "./test/testdata/addPragmas/"+ -- , "./test/testdata/badProjects/cabal/"+ -- , "./test/testdata/completion/"+ -- , "./test/testdata/definition/"+ -- , "./test/testdata/gototest/"+ -- , "./test/testdata/redundantImportTest/"+ -- , "./test/testdata/wErrorTest/"+ ]++data GhcVersion+ = GHC810+ | GHC88+ | GHC86+ | GHC84+ deriving (Eq,Show)++ghcVersion :: GhcVersion+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))+ghcVersion = GHC810+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))+ghcVersion = GHC88+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)))+ghcVersion = GHC86+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))+ghcVersion = GHC84+#endif++data EnvSpec = HostOS OS | GhcVer GhcVersion+ deriving (Show, Eq)++matchesCurrentEnv :: EnvSpec -> Bool+matchesCurrentEnv (HostOS os) = hostOS == os+matchesCurrentEnv (GhcVer ver) = ghcVersion == ver++data OS = Windows | MacOS | Linux+ deriving (Show, Eq)++hostOS :: OS+hostOS+ | isWindows = Windows+ | isMac = MacOS+ | otherwise = Linux++-- | Mark as broken if /any/ of environmental spec mathces the current environment.+knownBrokenInEnv :: [EnvSpec] -> String -> TestTree -> TestTree+knownBrokenInEnv envSpecs reason+ | any matchesCurrentEnv envSpecs = expectFailBecause reason+ | otherwise = id++knownBrokenOnWindows :: String -> TestTree -> TestTree+knownBrokenOnWindows reason+ | isWindows = expectFailBecause reason+ | otherwise = id++knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree+knownBrokenForGhcVersions vers reason+ | ghcVersion `elem` vers = expectFailBecause reason+ | otherwise = id++-- | IgnroeTest if /any/ of environmental spec mathces the current environment.+ignoreInEnv :: [EnvSpec] -> String -> TestTree -> TestTree+ignoreInEnv envSpecs reason+ | any matchesCurrentEnv envSpecs = ignoreTestBecause reason+ | otherwise = id++ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree+ignoreForGhcVersions vers reason+ | ghcVersion `elem` vers = ignoreTestBecause reason+ | otherwise = id++-- ---------------------------------------------------------------------++hieYamlCradleDirectContents :: String+hieYamlCradleDirectContents = unlines+ [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN"+ , "cradle:"+ , " direct:"+ , " arguments:"+ , " - -i."+ ]+++-- ---------------------------------------------------------------------++getHspecFormattedConfig :: String -> IO Config+getHspecFormattedConfig name = do+ -- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables+ isCI <- isJust <$> lookupEnv "CI"++ -- Only use the xml formatter on CI since it hides console output+ if isCI+ then do+ let subdir = "test-results" </> name+ createDirectoryIfMissing True subdir++ return $ defaultConfig { configFormatter = Just xmlFormatter+ , configOutputFile = Right $ subdir </> "results.xml"+ }+ else return defaultConfig++-- | A Hspec formatter for CircleCI.+-- Originally from https://github.com/LeastAuthority/hspec-jenkins+xmlFormatter :: Formatter+xmlFormatter = silent {+ headerFormatter = do+ writeLine "<?xml version='1.0' encoding='UTF-8'?>"+ writeLine "<testsuite>"+ , exampleSucceeded+ , exampleFailed+ , examplePending+ , footerFormatter = writeLine "</testsuite>"+ }+ where++#if MIN_VERSION_hspec(2,5,0)+ exampleSucceeded path _ =+#else+ exampleSucceeded path =+#endif+ writeLine $ renderMarkup $ testcase path ""++#if MIN_VERSION_hspec(2,5,0)+ exampleFailed path _ err =+#else+ exampleFailed path (Left err) =+ writeLine $ renderMarkup $ testcase path $+ failure ! message (show err) $ ""+ exampleFailed path (Right err) =+#endif+ writeLine $ renderMarkup $ testcase path $+ failure ! message (reasonAsString err) $ ""++#if MIN_VERSION_hspec(2,5,0)+ examplePending path _ reason =+#else+ examplePending path reason =+#endif+ writeLine $ renderMarkup $ testcase path $+ case reason of+ Just desc -> skipped ! message desc $ ""+ Nothing -> skipped ""++ failure, skipped :: Markup -> Markup+ failure = customParent "failure"+ skipped = customParent "skipped"++ name, className, message :: String -> Attribute+ name = customAttribute "name" . stringValue+ className = customAttribute "classname" . stringValue+ message = customAttribute "message" . stringValue++ testcase :: Path -> Markup -> Markup+ testcase (xs,x) = customParent "testcase" ! name x ! className (intercalate "." xs)++ reasonAsString :: FailureReason -> String+ reasonAsString NoReason = "no reason given"+ reasonAsString (Reason x) = x+ reasonAsString (ExpectedButGot Nothing expected got) = "Expected " ++ expected ++ " but got " ++ got+ reasonAsString (ExpectedButGot (Just src) expected got) = src ++ " expected " ++ expected ++ " but got " ++ got+#if MIN_VERSION_hspec(2,5,0)+ reasonAsString (Error Nothing err ) = show err+ reasonAsString (Error (Just s) err) = s ++ show err+#endif++-- ---------------------------------------------------------------------++flushStackEnvironment :: IO ()+flushStackEnvironment = do+ -- We need to clear these environment variables to prevent+ -- collisions with stack usages+ -- See https://github.com/commercialhaskell/stack/issues/4875+ unsetEnv "GHC_PACKAGE_PATH"+ unsetEnv "GHC_ENVIRONMENT"+ unsetEnv "HASKELL_PACKAGE_SANDBOX"+ unsetEnv "HASKELL_PACKAGE_SANDBOXES"++-- ---------------------------------------------------------------------++-- | Like 'withCurrentDirectory', but will copy the directory over to the system+-- temporary directory first to avoid haskell-language-server's source tree from+-- interfering with the cradle+withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a+withCurrentDirectoryInTmp dir f =+ withTempCopy dir $ \newDir ->+ withCurrentDirectory newDir f++withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a+withTempCopy srcDir f = do+ withSystemTempDirectory "hls-test" $ \newDir -> do+ copyDir srcDir newDir+ f newDir++copyDir :: FilePath -> FilePath -> IO ()+copyDir src dst = do+ cnts <- listDirectory src+ forM_ cnts $ \file -> do+ unless (file `elem` ignored) $ do+ let srcFp = src </> file+ dstFp = dst </> file+ isDir <- doesDirectoryExist srcFp+ if isDir+ then createDirectory dstFp >> copyDir srcFp dstFp+ else copyFile srcFp dstFp+ where ignored = ["dist", "dist-newstyle", ".stack-work"]++fromAction :: (Command |? CodeAction) -> CodeAction+fromAction (InR action) = action+fromAction _ = error "Not a code action"++fromCommand :: (Command |? CodeAction) -> Command+fromCommand (InL command) = command+fromCommand _ = error "Not a command"++onMatch :: [a] -> (a -> Bool) -> String -> IO a+onMatch as predicate err = maybe (fail err) return (find predicate as)++inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic+inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err+ where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one"++expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO ()+expectDiagnostic diags s = void $ inspectDiagnostic diags s++inspectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO CodeAction+inspectCodeAction cars s = fromAction <$> onMatch cars predicate err+ where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s+ predicate _ = False+ err = "expected code action matching '" ++ show s ++ "' but did not find one"++expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()+expectCodeAction cars s = void $ inspectCodeAction cars s++inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command+inspectCommand cars s = fromCommand <$> onMatch cars predicate err+ where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s+ predicate _ = False+ err = "expected code action matching '" ++ show s ++ "' but did not find one"++waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic]+waitForDiagnosticsFrom doc = do+ diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics)+ let (List diags) = diagsNot ^. L.params . L.diagnostics+ if doc ^. L.uri /= diagsNot ^. L.params . L.uri+ then waitForDiagnosticsFrom doc+ 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)++-- | wait for @timeout@ seconds and report an assertion failure+-- if any diagnostic messages arrive in that period+expectNoMoreDiagnostics :: Seconds -> TextDocumentIdentifier -> String -> Test.Session ()+expectNoMoreDiagnostics timeout doc src = do+ diags <- waitForDiagnosticsFromSourceWithTimeout timeout doc src+ unless (null diags) $+ liftIO $ assertFailure $+ "Got unexpected diagnostics for " <> show (doc ^. L.uri) <>+ " got " <> show diags++-- | wait for @timeout@ seconds and return diagnostics for the given @document and @source.+-- 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+ -- 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+ where+ matches :: Diagnostic -> Bool+ matches d = d ^. L.source == Just (T.pack source)++ handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers+ handleDiagnostic = 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++ ignoreOthers = void Test.anyMessage >> handleMessages++failIfSessionTimeout :: IO a -> IO a+failIfSessionTimeout action = action `catch` errorHandler+ where errorHandler :: Test.SessionException -> IO a+ errorHandler e@(Test.Timeout _) = assertFailure $ show e+ errorHandler e = throwIO e++-- | To locate a symbol, we provide a path to the file from the HLS root+-- directory, the line number, and the column number. (0 indexed.)+type SymbolLocation = (FilePath, Int, Int)++expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion+actual `expectSameLocations` expected = do+ let actual' =+ Set.map (\location -> (location ^. L.uri+ , location ^. L.range . L.start . L.line+ , location ^. L.range . L.start . L.character))+ $ Set.fromList actual+ expected' <- Set.fromList <$>+ (forM expected $ \(file, l, c) -> do+ fp <- canonicalizePath file+ return (filePathToUri fp, l, c))+ actual' @?= expected'