diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal new file mode 100644 --- /dev/null +++ b/hls-test-utils.cabal @@ -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 + +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 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls.hs @@ -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 diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls/Util.hs @@ -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 "" + writeLine "" + , exampleSucceeded + , exampleFailed + , examplePending + , footerFormatter = writeLine "" + } + 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'