{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
module Test.Hls.Util
  (
      codeActionSupportCaps
    , expectCodeAction
    , dontExpectCodeAction
    , expectDiagnostic
    , expectNoMoreDiagnostics
    , expectSameLocations
    , failIfSessionTimeout
    , flushStackEnvironment
    , fromAction
    , fromCommand
    , getCompletionByLabel
    , ghcVersion, GhcVersion(..)
    , hostOS, OS(..)
    , matchesCurrentEnv, EnvSpec(..)
    , noLiteralCaps
    , ignoreForGhcVersions
    , ignoreInEnv
    , onlyRunForGhcVersions
    , inspectCodeAction
    , inspectCommand
    , inspectDiagnostic
    , knownBrokenOnWindows
    , knownBrokenForGhcVersions
    , knownBrokenInEnv
    , onlyWorkForGhcVersions
    , setupBuildToolFiles
    , SymbolLocation
    , waitForDiagnosticsFrom
    , waitForDiagnosticsFromSource
    , waitForDiagnosticsFromSourceWithTimeout
    , withCurrentDirectoryInTmp
    , withCurrentDirectoryInTmp'
    , withCanonicalTempDir
  )
where

import           Control.Applicative.Combinators (skipManyTill, (<|>))
import           Control.Exception               (catch, throwIO)
import           Control.Lens                    ((&), (?~), (^.))
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Aeson                      as A
import           Data.Bool                       (bool)
import           Data.Default
import           Data.List.Extra                 (find)
import qualified Data.Set                        as Set
import qualified Data.Text                       as T
import           Development.IDE                 (GhcVersion (..), ghcVersion)
import qualified Language.LSP.Test               as Test
import           Language.LSP.Types              hiding (Reason (..))
import qualified Language.LSP.Types.Capabilities as C
import           Language.LSP.Types.Lens         (textDocument)
import qualified Language.LSP.Types.Lens         as L
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.Info.Extra               (isMac, isWindows)
import qualified System.IO.Extra
import           System.IO.Temp
import           System.Time.Extra               (Seconds, sleep)
import           Test.Tasty                      (TestTree)
import           Test.Tasty.ExpectedFailure      (expectFailBecause,
                                                  ignoreTestBecause)
import           Test.Tasty.HUnit                (Assertion, assertFailure,
                                                  (@?=))

noLiteralCaps :: C.ClientCapabilities
noLiteralCaps :: ClientCapabilities
noLiteralCaps = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall s a. HasTextDocument s a => Lens' s a
textDocument forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TextDocumentClientCapabilities
textDocumentCaps
  where
    textDocumentCaps :: TextDocumentClientCapabilities
textDocumentCaps = forall a. Default a => a
def { $sel:_codeAction:TextDocumentClientCapabilities :: Maybe CodeActionClientCapabilities
C._codeAction = 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 (forall a. a -> Maybe a
Just Bool
True) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

codeActionSupportCaps :: C.ClientCapabilities
codeActionSupportCaps :: ClientCapabilities
codeActionSupportCaps = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall s a. HasTextDocument s a => Lens' s a
textDocument forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TextDocumentClientCapabilities
textDocumentCaps
  where
    textDocumentCaps :: TextDocumentClientCapabilities
textDocumentCaps = forall a. Default a => a
def { $sel:_codeAction:TextDocumentClientCapabilities :: Maybe CodeActionClientCapabilities
C._codeAction = 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 (forall a. a -> Maybe a
Just Bool
True) (forall a. a -> Maybe a
Just CodeActionLiteralSupport
literalSupport) (forall a. a -> Maybe a
Just Bool
True) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    literalSupport :: CodeActionLiteralSupport
literalSupport = CodeActionKindClientCapabilities -> CodeActionLiteralSupport
CodeActionLiteralSupport forall a. Default a => a
def

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

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

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


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

files :: [FilePath]
files :: [String]
files =
  [  String
"./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 EnvSpec = HostOS OS | GhcVer GhcVersion
    deriving (Int -> EnvSpec -> ShowS
[EnvSpec] -> ShowS
EnvSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvSpec] -> ShowS
$cshowList :: [EnvSpec] -> ShowS
show :: EnvSpec -> String
$cshow :: EnvSpec -> String
showsPrec :: Int -> EnvSpec -> ShowS
$cshowsPrec :: Int -> EnvSpec -> ShowS
Show, EnvSpec -> EnvSpec -> Bool
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 forall a. Eq a => a -> a -> Bool
== OS
os
matchesCurrentEnv (GhcVer GhcVersion
ver) = GhcVersion
ghcVersion forall a. Eq a => a -> a -> Bool
== GhcVersion
ver

data OS = Windows | MacOS | Linux
    deriving (Int -> OS -> ShowS
[OS] -> ShowS
OS -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OS] -> ShowS
$cshowList :: [OS] -> ShowS
show :: OS -> String
$cshow :: OS -> String
showsPrec :: Int -> OS -> ShowS
$cshowsPrec :: Int -> OS -> ShowS
Show, OS -> OS -> Bool
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] -> String -> TestTree -> TestTree
knownBrokenInEnv [EnvSpec]
envSpecs String
reason
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EnvSpec -> Bool
matchesCurrentEnv [EnvSpec]
envSpecs = String -> TestTree -> TestTree
expectFailBecause String
reason
    | Bool
otherwise = forall a. a -> a
id

knownBrokenOnWindows :: String -> TestTree -> TestTree
knownBrokenOnWindows :: String -> TestTree -> TestTree
knownBrokenOnWindows = [EnvSpec] -> String -> TestTree -> TestTree
knownBrokenInEnv [OS -> EnvSpec
HostOS OS
Windows]

knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
knownBrokenForGhcVersions [GhcVersion]
vers = [EnvSpec] -> String -> TestTree -> TestTree
knownBrokenInEnv (forall a b. (a -> b) -> [a] -> [b]
map GhcVersion -> EnvSpec
GhcVer [GhcVersion]
vers)

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

ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
ignoreForGhcVersions [GhcVersion]
vers = [EnvSpec] -> String -> TestTree -> TestTree
ignoreInEnv (forall a b. (a -> b) -> [a] -> [b]
map GhcVersion -> EnvSpec
GhcVer [GhcVersion]
vers)

-- | Mark as broken if GHC does not match only work versions.
onlyWorkForGhcVersions :: (GhcVersion -> Bool) -> String -> TestTree -> TestTree
onlyWorkForGhcVersions :: (GhcVersion -> Bool) -> String -> TestTree -> TestTree
onlyWorkForGhcVersions GhcVersion -> Bool
p String
reason =
    if GhcVersion -> Bool
p GhcVersion
ghcVersion
        then forall a. a -> a
id
        else String -> TestTree -> TestTree
expectFailBecause String
reason

-- | Ignore the test if GHC does not match only work versions.
onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
onlyRunForGhcVersions [GhcVersion]
vers =
    if GhcVersion
ghcVersion forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GhcVersion]
vers
    then forall a b. a -> b -> a
const forall a. a -> a
id
    else String -> TestTree -> TestTree
ignoreTestBecause

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

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


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

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
  String -> IO ()
unsetEnv String
"GHC_PACKAGE_PATH"
  String -> IO ()
unsetEnv String
"GHC_ENVIRONMENT"
  String -> IO ()
unsetEnv String
"HASKELL_PACKAGE_SANDBOX"
  String -> IO ()
unsetEnv String
"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.
--
-- Ignores directories containing build artefacts to avoid interference and
-- provide reproducible test-behaviour.
withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
withCurrentDirectoryInTmp :: forall a. String -> IO a -> IO a
withCurrentDirectoryInTmp String
dir IO a
f =
  forall a. [String] -> String -> (String -> IO a) -> IO a
withTempCopy [String]
ignored String
dir forall a b. (a -> b) -> a -> b
$ \String
newDir ->
    forall a. String -> IO a -> IO a
withCurrentDirectory String
newDir IO a
f
  where
    ignored :: [String]
ignored = [String
"dist", String
"dist-newstyle", String
".stack-work"]


-- | 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.
--
-- You may specify directories to ignore, but should be careful to maintain reproducibility.
withCurrentDirectoryInTmp' :: [FilePath] -> FilePath -> IO a -> IO a
withCurrentDirectoryInTmp' :: forall a. [String] -> String -> IO a -> IO a
withCurrentDirectoryInTmp' [String]
ignored String
dir IO a
f =
  forall a. [String] -> String -> (String -> IO a) -> IO a
withTempCopy [String]
ignored String
dir forall a b. (a -> b) -> a -> b
$ \String
newDir ->
    forall a. String -> IO a -> IO a
withCurrentDirectory String
newDir IO a
f

-- | Example call: @withTempCopy ignored src f@
--
-- Copy directory 'src' to into a temporary directory ignoring any directories
-- (and files) that are listed in 'ignored'. Pass the temporary directory
-- containing the copied sources to the continuation.
withTempCopy :: [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
withTempCopy :: forall a. [String] -> String -> (String -> IO a) -> IO a
withTempCopy [String]
ignored String
srcDir String -> IO a
f = do
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hls-test" forall a b. (a -> b) -> a -> b
$ \String
newDir -> do
    [String] -> String -> String -> IO ()
copyDir [String]
ignored String
srcDir String
newDir
    String -> IO a
f String
newDir

-- | Example call: @copyDir ignored src dst@
--
-- Copy directory 'src' to 'dst' ignoring any directories (and files)
-- that are listed in 'ignored'.
copyDir :: [FilePath] -> FilePath -> FilePath -> IO ()
copyDir :: [String] -> String -> String -> IO ()
copyDir [String]
ignored String
src String
dst = do
  [String]
cnts <- String -> IO [String]
listDirectory String
src
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
cnts forall a b. (a -> b) -> a -> b
$ \String
file -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
file forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ignored) forall a b. (a -> b) -> a -> b
$ do
      let srcFp :: String
srcFp = String
src String -> ShowS
</> String
file
          dstFp :: String
dstFp = String
dst String -> ShowS
</> String
file
      Bool
isDir <- String -> IO Bool
doesDirectoryExist String
srcFp
      if Bool
isDir
        then String -> IO ()
createDirectory String
dstFp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> String -> String -> IO ()
copyDir [String]
ignored String
srcFp String
dstFp
        else String -> String -> IO ()
copyFile String
srcFp String
dstFp

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

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

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

noMatch :: [a] -> (a -> Bool) -> String -> IO ()
noMatch :: forall a. [a] -> (a -> Bool) -> String -> IO ()
noMatch [] a -> Bool
_ String
_           = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
noMatch [a]
as a -> Bool
predicate String
err = forall a. a -> a -> Bool -> a
bool (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err) (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any a -> Bool
predicate [a]
as)

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

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

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

dontExpectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()
dontExpectCodeAction :: [Command |? CodeAction] -> [Text] -> IO ()
dontExpectCodeAction [Command |? CodeAction]
cars [Text]
s =
  forall a. [a] -> (a -> Bool) -> String -> IO ()
noMatch [Command |? CodeAction]
cars (Command |? CodeAction) -> Bool
predicate String
err
    where predicate :: (Command |? CodeAction) -> Bool
predicate (InR CodeAction
ca) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Bool
`T.isInfixOf` (CodeAction
ca forall s a. s -> Getting a s a -> a
^. forall s a. HasTitle s a => Lens' s a
L.title)) [Text]
s
          predicate Command |? CodeAction
_        = Bool
False
          err :: String
err = String
"didn't expected code action matching '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Text]
s forall a. [a] -> [a] -> [a]
++ String
"' but found one anyway"


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

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

waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic]
waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Session [Diagnostic]
waitForDiagnosticsFromSource = Seconds -> TextDocumentIdentifier -> String -> Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout Seconds
5

-- | 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 -> String -> Session ()
expectNoMoreDiagnostics Seconds
timeout TextDocumentIdentifier
doc String
src = do
    [Diagnostic]
diags <- Seconds -> TextDocumentIdentifier -> String -> Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout Seconds
timeout TextDocumentIdentifier
doc String
src
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
diags) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
            String
"Got unexpected diagnostics for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (TextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri) forall a. Semigroup a => a -> a -> a
<>
            String
" got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
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 -> String -> Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout Seconds
timeout TextDocumentIdentifier
document String
source = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Seconds
timeout forall a. Ord a => a -> a -> Bool
> Seconds
0) forall a b. (a -> b) -> a -> b
$
        -- Give any further diagnostic messages time to arrive.
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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.
    LspId 'CustomMethod
testId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
Test.sendRequest (forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test") Value
A.Null
    LspId 'CustomMethod -> Session [Diagnostic]
handleMessages LspId 'CustomMethod
testId
  where
    matches :: Diagnostic -> Bool
    matches :: Diagnostic -> Bool
matches Diagnostic
d = Diagnostic
d forall s a. s -> Getting a s a -> a
^. forall s a. HasSource s a => Lens' s a
L.source forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (String -> Text
T.pack String
source)

    handleMessages :: LspId 'CustomMethod -> Session [Diagnostic]
handleMessages LspId 'CustomMethod
testId = LspId 'CustomMethod -> Session [Diagnostic]
handleDiagnostic LspId 'CustomMethod
testId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. LspId 'CustomMethod -> Session [a]
handleCustomMethodResponse LspId 'CustomMethod
testId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LspId 'CustomMethod -> Session [Diagnostic]
ignoreOthers LspId 'CustomMethod
testId
    handleDiagnostic :: LspId 'CustomMethod -> Session [Diagnostic]
handleDiagnostic LspId 'CustomMethod
testId = do
        NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot <- forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
Test.message SMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics
        let fileUri :: Uri
fileUri = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
            (List [Diagnostic]
diags) = NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics
            res :: [Diagnostic]
res = forall a. (a -> Bool) -> [a] -> [a]
filter Diagnostic -> Bool
matches [Diagnostic]
diags
        if Uri
fileUri forall a. Eq a => a -> a -> Bool
== TextDocumentIdentifier
document forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
res)
            then forall (m :: * -> *) a. Monad m => a -> m a
return [Diagnostic]
res else LspId 'CustomMethod -> Session [Diagnostic]
handleMessages LspId 'CustomMethod
testId
    handleCustomMethodResponse :: LspId 'CustomMethod -> Session [a]
handleCustomMethodResponse LspId 'CustomMethod
testId = do
        ResponseMessage 'CustomMethod
_ <- forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
Test.responseForId (forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test") LspId 'CustomMethod
testId
        forall (f :: * -> *) a. Applicative f => a -> f a
pure []

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

failIfSessionTimeout :: IO a -> IO a
failIfSessionTimeout :: forall a. IO a -> IO a
failIfSessionTimeout IO a
action = IO a
action forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall a. SessionException -> IO a
errorHandler
    where errorHandler :: Test.SessionException -> IO a
          errorHandler :: forall a. SessionException -> IO a
errorHandler e :: SessionException
e@(Test.Timeout Maybe FromServerMessage
_) = forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SessionException
e
          errorHandler SessionException
e                  = 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, UInt, UInt)

expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion
[Location]
actual expectSameLocations :: [Location] -> [SymbolLocation] -> IO ()
`expectSameLocations` [SymbolLocation]
expected = do
    let actual' :: Set (Uri, UInt, UInt)
actual' =
            forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Location
location -> (Location
location forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri
                                   , Location
location forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
L.range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLine s a => Lens' s a
L.line
                                   , Location
location forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
L.range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCharacter s a => Lens' s a
L.character))
            forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Location]
actual
    Set (Uri, UInt, UInt)
expected' <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SymbolLocation]
expected forall a b. (a -> b) -> a -> b
$ \(String
file, UInt
l, UInt
c) -> do
                              String
fp <- String -> IO String
canonicalizePath String
file
                              forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Uri
filePathToUri String
fp, UInt
l, UInt
c))
    Set (Uri, UInt, UInt)
actual' forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Set (Uri, UInt, UInt)
expected'

-- ---------------------------------------------------------------------
getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem
getCompletionByLabel :: forall (m :: * -> *).
MonadIO m =>
Text -> [CompletionItem] -> m CompletionItem
getCompletionByLabel Text
desiredLabel [CompletionItem]
compls =
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\CompletionItem
c -> CompletionItem
c forall s a. s -> Getting a s a -> a
^. forall s a. HasLabel s a => Lens' s a
L.label forall a. Eq a => a -> a -> Bool
== Text
desiredLabel) [CompletionItem]
compls of
        Just CompletionItem
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletionItem
c
        Maybe CompletionItem
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
            String
"Completion with label " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
desiredLabel
            forall a. Semigroup a => a -> a -> a
<> String
" not found in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. s -> Getting a s a -> a
^. forall s a. HasLabel s a => Lens' s a
L.label) [CompletionItem]
compls)

-- ---------------------------------------------------------------------
-- Run with a canonicalized temp dir
withCanonicalTempDir :: (FilePath -> IO a) -> IO a
withCanonicalTempDir :: forall a. (String -> IO a) -> IO a
withCanonicalTempDir String -> IO a
f = forall a. (String -> IO a) -> IO a
System.IO.Extra.withTempDir forall a b. (a -> b) -> a -> b
$ \String
dir -> do
  String
dir' <- String -> IO String
canonicalizePath String
dir
  String -> IO a
f String
dir'