{-# 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 :: ClientCapabilities
codeActionSupportCaps = ClientCapabilities
forall a. Default a => a
def { $sel:_textDocument:ClientCapabilities :: Maybe TextDocumentClientCapabilities
C._textDocument = TextDocumentClientCapabilities
-> Maybe TextDocumentClientCapabilities
forall a. a -> Maybe a
Just TextDocumentClientCapabilities
textDocumentCaps }
  where
    textDocumentCaps :: TextDocumentClientCapabilities
textDocumentCaps = TextDocumentClientCapabilities
forall a. Default a => a
def { $sel:_codeAction:TextDocumentClientCapabilities :: Maybe CodeActionClientCapabilities
C._codeAction = CodeActionClientCapabilities -> Maybe CodeActionClientCapabilities
forall a. a -> Maybe a
Just CodeActionClientCapabilities
codeActionCaps }
    codeActionCaps :: CodeActionClientCapabilities
codeActionCaps = Maybe Bool
-> Maybe CodeActionLiteralSupport
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe CodeActionResolveClientCapabilities
-> Maybe Bool
-> CodeActionClientCapabilities
CodeActionClientCapabilities (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (CodeActionLiteralSupport -> Maybe CodeActionLiteralSupport
forall a. a -> Maybe a
Just CodeActionLiteralSupport
literalSupport) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe CodeActionResolveClientCapabilities
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing
    literalSupport :: CodeActionLiteralSupport
literalSupport = CodeActionKindClientCapabilities -> CodeActionLiteralSupport
CodeActionLiteralSupport CodeActionKindClientCapabilities
forall a. Default a => a
def

-- ---------------------------------------------------------------------

setupBuildToolFiles :: IO ()
setupBuildToolFiles :: IO ()
setupBuildToolFiles = do
  [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files FilePath -> IO ()
setupDirectFilesIn

setupDirectFilesIn :: FilePath -> IO ()
setupDirectFilesIn :: FilePath -> IO ()
setupDirectFilesIn FilePath
f =
  FilePath -> FilePath -> IO ()
writeFile (FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"hie.yaml") FilePath
hieYamlCradleDirectContents


-- ---------------------------------------------------------------------

files :: [FilePath]
files :: [FilePath]
files =
  [  FilePath
"./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 (GhcVersion -> GhcVersion -> Bool
(GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> Bool) -> Eq GhcVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GhcVersion -> GhcVersion -> Bool
$c/= :: GhcVersion -> GhcVersion -> Bool
== :: GhcVersion -> GhcVersion -> Bool
$c== :: GhcVersion -> GhcVersion -> Bool
Eq,Int -> GhcVersion -> FilePath -> FilePath
[GhcVersion] -> FilePath -> FilePath
GhcVersion -> FilePath
(Int -> GhcVersion -> FilePath -> FilePath)
-> (GhcVersion -> FilePath)
-> ([GhcVersion] -> FilePath -> FilePath)
-> Show GhcVersion
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [GhcVersion] -> FilePath -> FilePath
$cshowList :: [GhcVersion] -> FilePath -> FilePath
show :: GhcVersion -> FilePath
$cshow :: GhcVersion -> FilePath
showsPrec :: Int -> GhcVersion -> FilePath -> FilePath
$cshowsPrec :: Int -> GhcVersion -> FilePath -> FilePath
Show)

ghcVersion :: GhcVersion
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
ghcVersion :: GhcVersion
ghcVersion = 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 (Int -> EnvSpec -> FilePath -> FilePath
[EnvSpec] -> FilePath -> FilePath
EnvSpec -> FilePath
(Int -> EnvSpec -> FilePath -> FilePath)
-> (EnvSpec -> FilePath)
-> ([EnvSpec] -> FilePath -> FilePath)
-> Show EnvSpec
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [EnvSpec] -> FilePath -> FilePath
$cshowList :: [EnvSpec] -> FilePath -> FilePath
show :: EnvSpec -> FilePath
$cshow :: EnvSpec -> FilePath
showsPrec :: Int -> EnvSpec -> FilePath -> FilePath
$cshowsPrec :: Int -> EnvSpec -> FilePath -> FilePath
Show, EnvSpec -> EnvSpec -> Bool
(EnvSpec -> EnvSpec -> Bool)
-> (EnvSpec -> EnvSpec -> Bool) -> Eq EnvSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnvSpec -> EnvSpec -> Bool
$c/= :: EnvSpec -> EnvSpec -> Bool
== :: EnvSpec -> EnvSpec -> Bool
$c== :: EnvSpec -> EnvSpec -> Bool
Eq)

matchesCurrentEnv :: EnvSpec -> Bool
matchesCurrentEnv :: EnvSpec -> Bool
matchesCurrentEnv (HostOS OS
os) = OS
hostOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
os
matchesCurrentEnv (GhcVer GhcVersion
ver) = GhcVersion
ghcVersion GhcVersion -> GhcVersion -> Bool
forall a. Eq a => a -> a -> Bool
== GhcVersion
ver

data OS = Windows | MacOS | Linux
    deriving (Int -> OS -> FilePath -> FilePath
[OS] -> FilePath -> FilePath
OS -> FilePath
(Int -> OS -> FilePath -> FilePath)
-> (OS -> FilePath) -> ([OS] -> FilePath -> FilePath) -> Show OS
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [OS] -> FilePath -> FilePath
$cshowList :: [OS] -> FilePath -> FilePath
show :: OS -> FilePath
$cshow :: OS -> FilePath
showsPrec :: Int -> OS -> FilePath -> FilePath
$cshowsPrec :: Int -> OS -> FilePath -> FilePath
Show, OS -> OS -> Bool
(OS -> OS -> Bool) -> (OS -> OS -> Bool) -> Eq OS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OS -> OS -> Bool
$c/= :: OS -> OS -> Bool
== :: OS -> OS -> Bool
$c== :: OS -> OS -> Bool
Eq)

hostOS :: OS
hostOS :: OS
hostOS
    | Bool
isWindows = OS
Windows
    | Bool
isMac = OS
MacOS
    | Bool
otherwise = OS
Linux

-- | Mark as broken if /any/ of environmental spec mathces the current environment.
knownBrokenInEnv :: [EnvSpec] -> String -> TestTree -> TestTree
knownBrokenInEnv :: [EnvSpec] -> FilePath -> TestTree -> TestTree
knownBrokenInEnv [EnvSpec]
envSpecs FilePath
reason
    | (EnvSpec -> Bool) -> [EnvSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EnvSpec -> Bool
matchesCurrentEnv [EnvSpec]
envSpecs = FilePath -> TestTree -> TestTree
expectFailBecause FilePath
reason
    | Bool
otherwise = TestTree -> TestTree
forall a. a -> a
id

knownBrokenOnWindows :: String -> TestTree -> TestTree
knownBrokenOnWindows :: FilePath -> TestTree -> TestTree
knownBrokenOnWindows FilePath
reason
    | Bool
isWindows = FilePath -> TestTree -> TestTree
expectFailBecause FilePath
reason
    | Bool
otherwise = TestTree -> TestTree
forall a. a -> a
id

knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
knownBrokenForGhcVersions :: [GhcVersion] -> FilePath -> TestTree -> TestTree
knownBrokenForGhcVersions [GhcVersion]
vers FilePath
reason
    | GhcVersion
ghcVersion GhcVersion -> [GhcVersion] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GhcVersion]
vers =  FilePath -> TestTree -> TestTree
expectFailBecause FilePath
reason
    | Bool
otherwise = TestTree -> TestTree
forall a. a -> a
id

-- | IgnroeTest if /any/ of environmental spec mathces the current environment.
ignoreInEnv :: [EnvSpec] -> String -> TestTree -> TestTree
ignoreInEnv :: [EnvSpec] -> FilePath -> TestTree -> TestTree
ignoreInEnv [EnvSpec]
envSpecs FilePath
reason
    | (EnvSpec -> Bool) -> [EnvSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EnvSpec -> Bool
matchesCurrentEnv [EnvSpec]
envSpecs = FilePath -> TestTree -> TestTree
ignoreTestBecause FilePath
reason
    | Bool
otherwise = TestTree -> TestTree
forall a. a -> a
id

ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
ignoreForGhcVersions :: [GhcVersion] -> FilePath -> TestTree -> TestTree
ignoreForGhcVersions [GhcVersion]
vers FilePath
reason
    | GhcVersion
ghcVersion GhcVersion -> [GhcVersion] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GhcVersion]
vers =  FilePath -> TestTree -> TestTree
ignoreTestBecause FilePath
reason
    | Bool
otherwise = TestTree -> TestTree
forall a. a -> a
id

-- ---------------------------------------------------------------------

hieYamlCradleDirectContents :: String
hieYamlCradleDirectContents :: FilePath
hieYamlCradleDirectContents = [FilePath] -> FilePath
unlines
  [ FilePath
"# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN"
  , FilePath
"cradle:"
  , FilePath
"  direct:"
  , FilePath
"    arguments:"
  , FilePath
"      - -i."
  ]


-- ---------------------------------------------------------------------

getHspecFormattedConfig :: String -> IO Config
getHspecFormattedConfig :: FilePath -> IO Config
getHspecFormattedConfig FilePath
name = do
  -- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables
  Bool
isCI <- Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CI"

  -- Only use the xml formatter on CI since it hides console output
  if Bool
isCI
    then do
      let subdir :: FilePath
subdir = FilePath
"test-results" FilePath -> FilePath -> FilePath
</> FilePath
name
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
subdir

      Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ Config
defaultConfig { configFormatter :: Maybe Formatter
configFormatter = Formatter -> Maybe Formatter
forall a. a -> Maybe a
Just Formatter
xmlFormatter
                             , configOutputFile :: Either Handle FilePath
configOutputFile = FilePath -> Either Handle FilePath
forall a b. b -> Either a b
Right (FilePath -> Either Handle FilePath)
-> FilePath -> Either Handle FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
subdir FilePath -> FilePath -> FilePath
</> FilePath
"results.xml"
                             }
    else Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
defaultConfig

-- | A Hspec formatter for CircleCI.
-- Originally from https://github.com/LeastAuthority/hspec-jenkins
xmlFormatter :: Formatter
xmlFormatter :: Formatter
xmlFormatter = Formatter
silent {
    headerFormatter :: FormatM ()
headerFormatter = do
      FilePath -> FormatM ()
writeLine FilePath
"<?xml version='1.0' encoding='UTF-8'?>"
      FilePath -> FormatM ()
writeLine FilePath
"<testsuite>"
  , Path -> FilePath -> FormatM ()
forall p. Path -> p -> FormatM ()
exampleSucceeded :: Path -> FilePath -> FormatM ()
exampleSucceeded :: forall p. Path -> p -> FormatM ()
exampleSucceeded
  , Path -> FilePath -> FailureReason -> FormatM ()
forall p. Path -> p -> FailureReason -> FormatM ()
exampleFailed :: Path -> FilePath -> FailureReason -> FormatM ()
exampleFailed :: forall p. Path -> p -> FailureReason -> FormatM ()
exampleFailed
  , Path -> FilePath -> Maybe FilePath -> FormatM ()
forall p. Path -> p -> Maybe FilePath -> FormatM ()
examplePending :: Path -> FilePath -> Maybe FilePath -> FormatM ()
examplePending :: forall p. Path -> p -> Maybe FilePath -> FormatM ()
examplePending
  , footerFormatter :: FormatM ()
footerFormatter = FilePath -> FormatM ()
writeLine FilePath
"</testsuite>"
  }
  where

#if MIN_VERSION_hspec(2,5,0)
    exampleSucceeded :: Path -> p -> FormatM ()
exampleSucceeded Path
path p
_ =
#else
    exampleSucceeded path =
#endif
      FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Markup -> FilePath
renderMarkup (Markup -> FilePath) -> Markup -> FilePath
forall a b. (a -> b) -> a -> b
$ Path -> Markup -> Markup
testcase Path
path Markup
""

#if MIN_VERSION_hspec(2,5,0)
    exampleFailed :: Path -> p -> FailureReason -> FormatM ()
exampleFailed Path
path p
_ FailureReason
err =
#else
    exampleFailed path (Left err) =
      writeLine $ renderMarkup $ testcase path $
        failure ! message (show err) $ ""
    exampleFailed path (Right err) =
#endif
      FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Markup -> FilePath
renderMarkup (Markup -> FilePath) -> Markup -> FilePath
forall a b. (a -> b) -> a -> b
$ Path -> Markup -> Markup
testcase Path
path (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
        Markup -> Markup
failure (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! FilePath -> Attribute
message (FailureReason -> FilePath
reasonAsString FailureReason
err) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
""

#if MIN_VERSION_hspec(2,5,0)
    examplePending :: Path -> p -> Maybe FilePath -> FormatM ()
examplePending Path
path p
_ Maybe FilePath
reason =
#else
    examplePending path reason =
#endif
      FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Markup -> FilePath
renderMarkup (Markup -> FilePath) -> Markup -> FilePath
forall a b. (a -> b) -> a -> b
$ Path -> Markup -> Markup
testcase Path
path (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
        case Maybe FilePath
reason of
          Just FilePath
desc -> Markup -> Markup
skipped (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! FilePath -> Attribute
message FilePath
desc  (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
""
          Maybe FilePath
Nothing -> Markup -> Markup
skipped Markup
""

    failure, skipped :: Markup -> Markup
    failure :: Markup -> Markup
failure = Tag -> Markup -> Markup
customParent Tag
"failure"
    skipped :: Markup -> Markup
skipped = Tag -> Markup -> Markup
customParent Tag
"skipped"

    name, className, message :: String -> Attribute
    name :: FilePath -> Attribute
name = Tag -> AttributeValue -> Attribute
customAttribute Tag
"name" (AttributeValue -> Attribute)
-> (FilePath -> AttributeValue) -> FilePath -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> AttributeValue
stringValue
    className :: FilePath -> Attribute
className = Tag -> AttributeValue -> Attribute
customAttribute Tag
"classname" (AttributeValue -> Attribute)
-> (FilePath -> AttributeValue) -> FilePath -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> AttributeValue
stringValue
    message :: FilePath -> Attribute
message = Tag -> AttributeValue -> Attribute
customAttribute Tag
"message" (AttributeValue -> Attribute)
-> (FilePath -> AttributeValue) -> FilePath -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> AttributeValue
stringValue

    testcase :: Path -> Markup -> Markup
    testcase :: Path -> Markup -> Markup
testcase ([FilePath]
xs,FilePath
x) = Tag -> Markup -> Markup
customParent Tag
"testcase" (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! FilePath -> Attribute
name FilePath
x (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! FilePath -> Attribute
className (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." [FilePath]
xs)

    reasonAsString :: FailureReason -> String
    reasonAsString :: FailureReason -> FilePath
reasonAsString FailureReason
NoReason = FilePath
"no reason given"
    reasonAsString (Reason FilePath
x) = FilePath
x
    reasonAsString (ExpectedButGot Maybe FilePath
Nothing FilePath
expected FilePath
got) = FilePath
"Expected " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
expected FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" but got " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
got
    reasonAsString (ExpectedButGot (Just FilePath
src) FilePath
expected FilePath
got) = FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" expected " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
expected FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" but got " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
got
#if MIN_VERSION_hspec(2,5,0)
    reasonAsString (Error Maybe FilePath
Nothing SomeException
err ) = SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
    reasonAsString (Error (Just FilePath
s) SomeException
err) = FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
#endif

-- ---------------------------------------------------------------------

flushStackEnvironment :: IO ()
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
  FilePath -> IO ()
unsetEnv FilePath
"GHC_PACKAGE_PATH"
  FilePath -> IO ()
unsetEnv FilePath
"GHC_ENVIRONMENT"
  FilePath -> IO ()
unsetEnv FilePath
"HASKELL_PACKAGE_SANDBOX"
  FilePath -> IO ()
unsetEnv FilePath
"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 :: FilePath -> IO a -> IO a
withCurrentDirectoryInTmp FilePath
dir IO a
f =
  FilePath -> (FilePath -> IO a) -> IO a
forall a. FilePath -> (FilePath -> IO a) -> IO a
withTempCopy FilePath
dir ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
newDir ->
    FilePath -> IO a -> IO a
forall a. FilePath -> IO a -> IO a
withCurrentDirectory FilePath
newDir IO a
f

withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a
withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a
withTempCopy FilePath
srcDir FilePath -> IO a
f = do
  FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"hls-test" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
newDir -> do
    FilePath -> FilePath -> IO ()
copyDir FilePath
srcDir FilePath
newDir
    FilePath -> IO a
f FilePath
newDir

copyDir :: FilePath -> FilePath -> IO ()
copyDir :: FilePath -> FilePath -> IO ()
copyDir FilePath
src FilePath
dst = do
  [FilePath]
cnts <- FilePath -> IO [FilePath]
listDirectory FilePath
src
  [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
cnts ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
file FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
ignored) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let srcFp :: FilePath
srcFp = FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
file
          dstFp :: FilePath
dstFp = FilePath
dst FilePath -> FilePath -> FilePath
</> FilePath
file
      Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
srcFp
      if Bool
isDir
        then FilePath -> IO ()
createDirectory FilePath
dstFp IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> FilePath -> IO ()
copyDir FilePath
srcFp FilePath
dstFp
        else FilePath -> FilePath -> IO ()
copyFile FilePath
srcFp FilePath
dstFp
  where ignored :: [FilePath]
ignored = [FilePath
"dist", FilePath
"dist-newstyle", FilePath
".stack-work"]

fromAction :: (Command |? CodeAction) -> CodeAction
fromAction :: (Command |? CodeAction) -> CodeAction
fromAction (InR CodeAction
action) = CodeAction
action
fromAction Command |? CodeAction
_ = FilePath -> CodeAction
forall a. HasCallStack => FilePath -> a
error FilePath
"Not a code action"

fromCommand :: (Command |? CodeAction) -> Command
fromCommand :: (Command |? CodeAction) -> Command
fromCommand (InL Command
command) = Command
command
fromCommand Command |? CodeAction
_ = FilePath -> Command
forall a. HasCallStack => FilePath -> a
error FilePath
"Not a command"

onMatch :: [a] -> (a -> Bool) -> String -> IO a
onMatch :: [a] -> (a -> Bool) -> FilePath -> IO a
onMatch [a]
as a -> Bool
predicate FilePath
err = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err) a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find a -> Bool
predicate [a]
as)

inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic
inspectDiagnostic :: [Diagnostic] -> [Text] -> IO Diagnostic
inspectDiagnostic [Diagnostic]
diags [Text]
s = [Diagnostic] -> (Diagnostic -> Bool) -> FilePath -> IO Diagnostic
forall a. [a] -> (a -> Bool) -> FilePath -> IO a
onMatch [Diagnostic]
diags (\Diagnostic
ca -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Bool
`T.isInfixOf` (Diagnostic
ca Diagnostic -> Getting Text Diagnostic Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Diagnostic Text
forall s a. HasMessage s a => Lens' s a
L.message)) [Text]
s) FilePath
err
    where err :: FilePath
err = FilePath
"expected diagnostic matching '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' but did not find one"

expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO ()
expectDiagnostic :: [Diagnostic] -> [Text] -> IO ()
expectDiagnostic [Diagnostic]
diags [Text]
s = IO Diagnostic -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Diagnostic -> IO ()) -> IO Diagnostic -> IO ()
forall a b. (a -> b) -> a -> b
$ [Diagnostic] -> [Text] -> IO Diagnostic
inspectDiagnostic [Diagnostic]
diags [Text]
s

inspectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO CodeAction
inspectCodeAction :: [Command |? CodeAction] -> [Text] -> IO CodeAction
inspectCodeAction [Command |? CodeAction]
cars [Text]
s = (Command |? CodeAction) -> CodeAction
fromAction ((Command |? CodeAction) -> CodeAction)
-> IO (Command |? CodeAction) -> IO CodeAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Command |? CodeAction]
-> ((Command |? CodeAction) -> Bool)
-> FilePath
-> IO (Command |? CodeAction)
forall a. [a] -> (a -> Bool) -> FilePath -> IO a
onMatch [Command |? CodeAction]
cars (Command |? CodeAction) -> Bool
predicate FilePath
err
    where predicate :: (Command |? CodeAction) -> Bool
predicate (InR CodeAction
ca) = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Bool
`T.isInfixOf` (CodeAction
ca CodeAction -> Getting Text CodeAction Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text CodeAction Text
forall s a. HasTitle s a => Lens' s a
L.title)) [Text]
s
          predicate Command |? CodeAction
_ = Bool
False
          err :: FilePath
err = FilePath
"expected code action matching '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' but did not find one"

expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()
expectCodeAction :: [Command |? CodeAction] -> [Text] -> IO ()
expectCodeAction [Command |? CodeAction]
cars [Text]
s = IO CodeAction -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CodeAction -> IO ()) -> IO CodeAction -> IO ()
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Text] -> IO CodeAction
inspectCodeAction [Command |? CodeAction]
cars [Text]
s

inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command
inspectCommand :: [Command |? CodeAction] -> [Text] -> IO Command
inspectCommand [Command |? CodeAction]
cars [Text]
s = (Command |? CodeAction) -> Command
fromCommand ((Command |? CodeAction) -> Command)
-> IO (Command |? CodeAction) -> IO Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Command |? CodeAction]
-> ((Command |? CodeAction) -> Bool)
-> FilePath
-> IO (Command |? CodeAction)
forall a. [a] -> (a -> Bool) -> FilePath -> IO a
onMatch [Command |? CodeAction]
cars (Command |? CodeAction) -> Bool
predicate FilePath
err
    where predicate :: (Command |? CodeAction) -> Bool
predicate (InL Command
command) = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all  (Text -> Text -> Bool
`T.isInfixOf` (Command
command Command -> Getting Text Command Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Command Text
forall s a. HasTitle s a => Lens' s a
L.title)) [Text]
s
          predicate Command |? CodeAction
_ = Bool
False
          err :: FilePath
err = FilePath
"expected code action matching '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' but did not find one"

waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic]
waitForDiagnosticsFrom :: TextDocumentIdentifier -> Session [Diagnostic]
waitForDiagnosticsFrom TextDocumentIdentifier
doc = do
    NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot <- Session FromServerMessage
-> Session (NotificationMessage 'TextDocumentPublishDiagnostics)
-> Session (NotificationMessage 'TextDocumentPublishDiagnostics)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
Test.anyMessage (SServerMethod 'TextDocumentPublishDiagnostics
-> Session (ServerMessage 'TextDocumentPublishDiagnostics)
forall (t :: MethodType) (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
Test.message SServerMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics)
    let (List [Diagnostic]
diags) = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const (List Diagnostic) PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams
  -> Const (List Diagnostic) PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const
      (List Diagnostic)
      (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
    -> PublishDiagnosticsParams
    -> Const (List Diagnostic) PublishDiagnosticsParams)
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
-> PublishDiagnosticsParams
-> Const (List Diagnostic) PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics
    if TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
L.uri Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
/= NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
L.uri
       then TextDocumentIdentifier -> Session [Diagnostic]
waitForDiagnosticsFrom TextDocumentIdentifier
doc
       else [Diagnostic] -> Session [Diagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return [Diagnostic]
diags

waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic]
waitForDiagnosticsFromSource :: TextDocumentIdentifier -> FilePath -> Session [Diagnostic]
waitForDiagnosticsFromSource TextDocumentIdentifier
doc FilePath
src = do
    NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot <- Session FromServerMessage
-> Session (NotificationMessage 'TextDocumentPublishDiagnostics)
-> Session (NotificationMessage 'TextDocumentPublishDiagnostics)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
Test.anyMessage (SServerMethod 'TextDocumentPublishDiagnostics
-> Session (ServerMessage 'TextDocumentPublishDiagnostics)
forall (t :: MethodType) (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
Test.message SServerMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics)
    let (List [Diagnostic]
diags) = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const (List Diagnostic) PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams
  -> Const (List Diagnostic) PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const
      (List Diagnostic)
      (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
    -> PublishDiagnosticsParams
    -> Const (List Diagnostic) PublishDiagnosticsParams)
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
-> PublishDiagnosticsParams
-> Const (List Diagnostic) PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics
    let res :: [Diagnostic]
res = (Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter Diagnostic -> Bool
matches [Diagnostic]
diags
    if TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
L.uri Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
/= NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
L.uri Bool -> Bool -> Bool
|| [Diagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
res
       then TextDocumentIdentifier -> FilePath -> Session [Diagnostic]
waitForDiagnosticsFromSource TextDocumentIdentifier
doc FilePath
src
       else [Diagnostic] -> Session [Diagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return [Diagnostic]
res
  where
    matches :: Diagnostic -> Bool
    matches :: Diagnostic -> Bool
matches Diagnostic
d = Diagnostic
d Diagnostic
-> Getting (Maybe Text) Diagnostic (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Diagnostic (Maybe Text)
forall s a. HasSource s a => Lens' s a
L.source Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack FilePath
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 :: Seconds -> TextDocumentIdentifier -> FilePath -> Session ()
expectNoMoreDiagnostics Seconds
timeout TextDocumentIdentifier
doc FilePath
src = do
    [Diagnostic]
diags <- Seconds
-> TextDocumentIdentifier -> FilePath -> Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout Seconds
timeout TextDocumentIdentifier
doc FilePath
src
    Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Diagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
diags) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$
        IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"Got unexpected diagnostics for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Uri -> FilePath
forall a. Show a => a -> FilePath
show (TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
L.uri) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
            FilePath
" got " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Diagnostic] -> FilePath
forall a. Show a => a -> FilePath
show [Diagnostic]
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 :: Seconds
-> TextDocumentIdentifier -> FilePath -> Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout Seconds
timeout TextDocumentIdentifier
document FilePath
source = do
    Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Seconds
timeout Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
> Seconds
0) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ do
        -- Give any further diagnostic messages time to arrive.
        IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
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.
        Session () -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ SClientMethod 'CustomMethod
-> MessageParams 'CustomMethod -> Session ()
forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
Test.sendNotification (Text -> SClientMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"non-existent-method") Value
MessageParams 'CustomMethod
A.Null
    Session [Diagnostic]
handleMessages
  where
    matches :: Diagnostic -> Bool
    matches :: Diagnostic -> Bool
matches Diagnostic
d = Diagnostic
d Diagnostic
-> Getting (Maybe Text) Diagnostic (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Diagnostic (Maybe Text)
forall s a. HasSource s a => Lens' s a
L.source Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack FilePath
source)

    handleMessages :: Session [Diagnostic]
handleMessages = Session [Diagnostic]
handleDiagnostic Session [Diagnostic]
-> Session [Diagnostic] -> Session [Diagnostic]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Session [Diagnostic]
forall a. Session [a]
handleCustomMethodResponse Session [Diagnostic]
-> Session [Diagnostic] -> Session [Diagnostic]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Session [Diagnostic]
ignoreOthers
    handleDiagnostic :: Session [Diagnostic]
handleDiagnostic = do
        NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot <- SServerMethod 'TextDocumentPublishDiagnostics
-> Session (ServerMessage 'TextDocumentPublishDiagnostics)
forall (t :: MethodType) (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
Test.message SServerMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics
        let fileUri :: Uri
fileUri = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
L.uri
            (List [Diagnostic]
diags) = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const (List Diagnostic) PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
L.params ((PublishDiagnosticsParams
  -> Const (List Diagnostic) PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const
      (List Diagnostic)
      (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
    -> PublishDiagnosticsParams
    -> Const (List Diagnostic) PublishDiagnosticsParams)
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
-> PublishDiagnosticsParams
-> Const (List Diagnostic) PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics
            res :: [Diagnostic]
res = (Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter Diagnostic -> Bool
matches [Diagnostic]
diags
        if Uri
fileUri Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
== TextDocumentIdentifier
document TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
L.uri Bool -> Bool -> Bool
&& Bool -> Bool
not ([Diagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
res)
            then [Diagnostic] -> Session [Diagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return [Diagnostic]
diags else Session [Diagnostic]
handleMessages
    handleCustomMethodResponse :: Session [a]
handleCustomMethodResponse =
        -- the CustomClientMethod triggers a RspCustomServer
        -- handle that and then exit
        Session FromServerMessage -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((FromServerMessage -> Maybe FromServerMessage)
-> Session FromServerMessage
forall a. (FromServerMessage -> Maybe a) -> Session a
Test.satisfyMaybe FromServerMessage -> Maybe FromServerMessage
responseForNonExistentMethod) Session () -> Session [a] -> Session [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Session [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage
    responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage
responseForNonExistentMethod FromServerMessage
notif
        | FromServerMess SMethod m
SWindowLogMessage Message m
logMsg <- FromServerMessage
notif,
          Text
"non-existent-method" Text -> Text -> Bool
`T.isInfixOf` (Message m
NotificationMessage 'WindowLogMessage
logMsg NotificationMessage 'WindowLogMessage
-> Getting Text (NotificationMessage 'WindowLogMessage) Text
-> Text
forall s a. s -> Getting a s a -> a
^. (LogMessageParams -> Const Text LogMessageParams)
-> NotificationMessage 'WindowLogMessage
-> Const Text (NotificationMessage 'WindowLogMessage)
forall s a. HasParams s a => Lens' s a
L.params ((LogMessageParams -> Const Text LogMessageParams)
 -> NotificationMessage 'WindowLogMessage
 -> Const Text (NotificationMessage 'WindowLogMessage))
-> ((Text -> Const Text Text)
    -> LogMessageParams -> Const Text LogMessageParams)
-> Getting Text (NotificationMessage 'WindowLogMessage) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> LogMessageParams -> Const Text LogMessageParams
forall s a. HasMessage s a => Lens' s a
L.message)  = FromServerMessage -> Maybe FromServerMessage
forall a. a -> Maybe a
Just FromServerMessage
notif
        | Bool
otherwise = Maybe FromServerMessage
forall a. Maybe a
Nothing

    ignoreOthers :: Session [Diagnostic]
ignoreOthers = Session FromServerMessage -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
Test.anyMessage Session () -> Session [Diagnostic] -> Session [Diagnostic]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session [Diagnostic]
handleMessages

failIfSessionTimeout :: IO a -> IO a
failIfSessionTimeout :: IO a -> IO a
failIfSessionTimeout IO a
action = IO a
action IO a -> (SessionException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SessionException -> IO a
forall a. SessionException -> IO a
errorHandler
    where errorHandler :: Test.SessionException -> IO a
          errorHandler :: SessionException -> IO a
errorHandler e :: SessionException
e@(Test.Timeout Maybe FromServerMessage
_) = FilePath -> IO a
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ SessionException -> FilePath
forall a. Show a => a -> FilePath
show SessionException
e
          errorHandler SessionException
e = SessionException -> IO a
forall e a. Exception e => e -> IO a
throwIO SessionException
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
[Location]
actual expectSameLocations :: [Location] -> [SymbolLocation] -> IO ()
`expectSameLocations` [SymbolLocation]
expected = do
    let actual' :: Set (Uri, Int, Int)
actual' =
            (Location -> (Uri, Int, Int))
-> Set Location -> Set (Uri, Int, Int)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Location
location -> (Location
location Location -> Getting Uri Location Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri Location Uri
forall s a. HasUri s a => Lens' s a
L.uri
                                   , Location
location Location -> Getting Int Location Int -> Int
forall s a. s -> Getting a s a -> a
^. (Range -> Const Int Range) -> Location -> Const Int Location
forall s a. HasRange s a => Lens' s a
L.range ((Range -> Const Int Range) -> Location -> Const Int Location)
-> ((Int -> Const Int Int) -> Range -> Const Int Range)
-> Getting Int Location Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
L.start ((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> Range
-> Const Int Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
L.line
                                   , Location
location Location -> Getting Int Location Int -> Int
forall s a. s -> Getting a s a -> a
^. (Range -> Const Int Range) -> Location -> Const Int Location
forall s a. HasRange s a => Lens' s a
L.range ((Range -> Const Int Range) -> Location -> Const Int Location)
-> ((Int -> Const Int Int) -> Range -> Const Int Range)
-> Getting Int Location Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
L.start ((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> (Int -> Const Int Int)
-> Range
-> Const Int Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
L.character))
            (Set Location -> Set (Uri, Int, Int))
-> Set Location -> Set (Uri, Int, Int)
forall a b. (a -> b) -> a -> b
$ [Location] -> Set Location
forall a. Ord a => [a] -> Set a
Set.fromList [Location]
actual
    Set (Uri, Int, Int)
expected' <- [(Uri, Int, Int)] -> Set (Uri, Int, Int)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Uri, Int, Int)] -> Set (Uri, Int, Int))
-> IO [(Uri, Int, Int)] -> IO (Set (Uri, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ([SymbolLocation]
-> (SymbolLocation -> IO (Uri, Int, Int)) -> IO [(Uri, Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SymbolLocation]
expected ((SymbolLocation -> IO (Uri, Int, Int)) -> IO [(Uri, Int, Int)])
-> (SymbolLocation -> IO (Uri, Int, Int)) -> IO [(Uri, Int, Int)]
forall a b. (a -> b) -> a -> b
$ \(FilePath
file, Int
l, Int
c) -> do
                              FilePath
fp <- FilePath -> IO FilePath
canonicalizePath FilePath
file
                              (Uri, Int, Int) -> IO (Uri, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Uri
filePathToUri FilePath
fp, Int
l, Int
c))
    Set (Uri, Int, Int)
actual' Set (Uri, Int, Int) -> Set (Uri, Int, Int) -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Set (Uri, Int, Int)
expected'