{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
module Test.Hls.Util
  (  -- * Test Capabilities
      codeActionResolveCaps
    , codeActionNoResolveCaps
    , codeActionSupportCaps
    , expectCodeAction
    -- * Environment specifications
    -- for ignoring tests
    , ghcVersion, GhcVersion(..)
    , hostOS, OS(..)
    , matchesCurrentEnv, EnvSpec(..)
    , ignoreForGhcVersions
    , ignoreInEnv
    , onlyRunForGhcVersions
    , knownBrokenOnWindows
    , knownBrokenForGhcVersions
    , knownBrokenInEnv
    , onlyWorkForGhcVersions
    -- * Extract code actions
    , fromAction
    , fromCommand
    -- * Session Assertion Helpers
    , dontExpectCodeAction
    , expectDiagnostic
    , expectNoMoreDiagnostics
    , expectSameLocations
    , failIfSessionTimeout
    , getCompletionByLabel
    , noLiteralCaps
    , inspectCodeAction
    , inspectCommand
    , inspectDiagnostic
    , SymbolLocation
    , waitForDiagnosticsFrom
    , waitForDiagnosticsFromSource
    , waitForDiagnosticsFromSourceWithTimeout
    -- * Temporary directories
    , withCurrentDirectoryInTmp
    , withCurrentDirectoryInTmp'
    , withCanonicalTempDir
  )
where

import           Control.Applicative.Combinators (skipManyTill, (<|>))
import           Control.Exception               (catch, throwIO)
import           Control.Lens                    ((&), (?~), (^.), _Just, (.~))
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Aeson                      as A
import           Data.Bool                       (bool)
import           Data.Default
import           Data.Row
import           Data.Proxy
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.Protocol.Types
import           Language.LSP.Protocol.Message
import qualified Language.LSP.Protocol.Lens         as L
import           System.Directory
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 :: 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
L.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
_codeAction = forall a. a -> Maybe a
Just CodeActionClientCapabilities
codeActionCaps }
    codeActionCaps :: CodeActionClientCapabilities
codeActionCaps = Maybe Bool
-> Maybe
     (Rec
        (("codeActionKind"
          .== Rec (("valueSet" .== [CodeActionKind]) .+ Empty))
         .+ Empty))
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe (Rec (("properties" .== [Text]) .+ Empty))
-> 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 :: 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
L.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
_codeAction = forall a. a -> Maybe a
Just CodeActionClientCapabilities
codeActionCaps }
    codeActionCaps :: CodeActionClientCapabilities
codeActionCaps = Maybe Bool
-> Maybe
     (Rec
        (("codeActionKind"
          .== Rec (("valueSet" .== [CodeActionKind]) .+ Empty))
         .+ Empty))
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe (Rec (("properties" .== [Text]) .+ Empty))
-> Maybe Bool
-> CodeActionClientCapabilities
CodeActionClientCapabilities (forall a. a -> Maybe a
Just Bool
True) (forall a. a -> Maybe a
Just forall {a}.
Rec ('R '[ "codeActionKind" ':-> Rec ('R '[ "valueSet" ':-> [a]])])
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 :: Rec ("codeActionKind" .== Rec ('R '[ "valueSet" ':-> [a]]))
literalSupport = forall a. IsLabel "codeActionKind" a => a
#codeActionKind forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.==  (forall a. IsLabel "valueSet" a => a
#valueSet forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== [])

codeActionResolveCaps :: ClientCapabilities
codeActionResolveCaps :: ClientCapabilities
codeActionResolveCaps = ClientCapabilities
Test.fullCaps
                          forall a b. a -> (a -> b) -> b
& (forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeAction s a => Lens' s a
L.codeAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasResolveSupport s a => Lens' s a
L.resolveSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. IsLabel "properties" a => a
#properties forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== [Text
"edit"])
                          forall a b. a -> (a -> b) -> b
& (forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeAction s a => Lens' s a
L.codeAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDataSupport s a => Lens' s a
L.dataSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True

codeActionNoResolveCaps :: ClientCapabilities
codeActionNoResolveCaps :: ClientCapabilities
codeActionNoResolveCaps = ClientCapabilities
Test.fullCaps
                          forall a b. a -> (a -> b) -> b
& (forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeAction s a => Lens' s a
L.codeAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasResolveSupport s a => Lens' s a
L.resolveSupport) forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing
                          forall a b. a -> (a -> b) -> b
& (forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeAction s a => Lens' s a
L.codeAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDataSupport s a => Lens' s a
L.dataSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
-- ---------------------------------------------------------------------
-- Environment specification for ignoring tests
-- ---------------------------------------------------------------------

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

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

-- | 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
    TNotificationMessage 'Method_TextDocumentPublishDiagnostics
diagsNot <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
Test.anyMessage (forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> Session (TMessage m)
Test.message SMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics)
    let diags :: [Diagnostic]
diags = TNotificationMessage 'Method_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
/= TNotificationMessage 'Method_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 ('Method_CustomMethod "test")
testId <- forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
Test.sendRequest (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")) Value
A.Null
    LspId ('Method_CustomMethod "test") -> Session [Diagnostic]
handleMessages LspId ('Method_CustomMethod "test")
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 ('Method_CustomMethod "test") -> Session [Diagnostic]
handleMessages LspId ('Method_CustomMethod "test")
testId = LspId ('Method_CustomMethod "test") -> Session [Diagnostic]
handleDiagnostic LspId ('Method_CustomMethod "test")
testId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. LspId ('Method_CustomMethod "test") -> Session [a]
handleMethod_CustomMethodResponse LspId ('Method_CustomMethod "test")
testId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LspId ('Method_CustomMethod "test") -> Session [Diagnostic]
ignoreOthers LspId ('Method_CustomMethod "test")
testId
    handleDiagnostic :: LspId ('Method_CustomMethod "test") -> Session [Diagnostic]
handleDiagnostic LspId ('Method_CustomMethod "test")
testId = do
        TNotificationMessage 'Method_TextDocumentPublishDiagnostics
diagsNot <- forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> Session (TMessage m)
Test.message SMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics
        let fileUri :: Uri
fileUri = TNotificationMessage 'Method_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
            ( [Diagnostic]
diags) = TNotificationMessage 'Method_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 ('Method_CustomMethod "test") -> Session [Diagnostic]
handleMessages LspId ('Method_CustomMethod "test")
testId
    handleMethod_CustomMethodResponse :: LspId ('Method_CustomMethod "test") -> Session [a]
handleMethod_CustomMethodResponse LspId ('Method_CustomMethod "test")
testId = do
        TResponseMessage ('Method_CustomMethod "test")
_ <- forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
Test.responseForId (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")) LspId ('Method_CustomMethod "test")
testId
        forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    ignoreOthers :: LspId ('Method_CustomMethod "test") -> Session [Diagnostic]
ignoreOthers LspId ('Method_CustomMethod "test")
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 ('Method_CustomMethod "test") -> Session [Diagnostic]
handleMessages LspId ('Method_CustomMethod "test")
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'