{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
module Test.Hls.Util
  (
      codeActionSupportCaps
    , expectCodeAction
    , dontExpectCodeAction
    , 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
    , withCurrentDirectoryInTmp'
  )
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                       (intercalate)
import           Data.List.Extra                 (find)
import           Data.Maybe
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 qualified Language.LSP.Types.Lens         as L
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.IO.Temp
import           System.Info.Extra               (isMac, isWindows)
import           System.Time.Extra               (Seconds, sleep)
import           Test.Hspec.Core.Formatters      hiding (Seconds)
import           Test.Hspec.Runner
import           Test.Tasty                      (TestTree)
import           Test.Tasty.ExpectedFailure      (expectFailBecause,
                                                  ignoreTestBecause)
import           Test.Tasty.HUnit                (Assertion, assertFailure,
                                                  (@?=))
import           Text.Blaze.Internal             hiding (null)
import           Text.Blaze.Renderer.String      (renderMarkup)

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 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 = [EnvSpec] -> FilePath -> TestTree -> TestTree
knownBrokenInEnv [OS -> EnvSpec
HostOS OS
Windows]

knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
knownBrokenForGhcVersions :: [GhcVersion] -> FilePath -> TestTree -> TestTree
knownBrokenForGhcVersions [GhcVersion]
vers = [EnvSpec] -> FilePath -> TestTree -> TestTree
knownBrokenInEnv ((GhcVersion -> EnvSpec) -> [GhcVersion] -> [EnvSpec]
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] -> 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 = [EnvSpec] -> FilePath -> TestTree -> TestTree
ignoreInEnv ((GhcVersion -> EnvSpec) -> [GhcVersion] -> [EnvSpec]
forall a b. (a -> b) -> [a] -> [b]
map GhcVersion -> EnvSpec
GhcVer [GhcVersion]
vers)

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

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.
--
-- Ignores directories containing build artefacts to avoid interference and
-- provide reproducible test-behaviour.
withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
withCurrentDirectoryInTmp FilePath
dir IO a
f =
  [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
forall a. [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
withTempCopy [FilePath]
ignored 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
  where
    ignored :: [FilePath]
ignored = [FilePath
"dist", FilePath
"dist-newstyle", FilePath
".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' :: [FilePath] -> FilePath -> IO a -> IO a
withCurrentDirectoryInTmp' [FilePath]
ignored FilePath
dir IO a
f =
  [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
forall a. [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
withTempCopy [FilePath]
ignored 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

-- | 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 :: [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a
withTempCopy [FilePath]
ignored 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 -> FilePath -> IO ()
copyDir [FilePath]
ignored FilePath
srcDir FilePath
newDir
    FilePath -> IO a
f FilePath
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 :: [FilePath] -> FilePath -> FilePath -> IO ()
copyDir [FilePath]
ignored 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 -> FilePath -> IO ()
copyDir [FilePath]
ignored FilePath
srcFp FilePath
dstFp
        else FilePath -> FilePath -> IO ()
copyFile FilePath
srcFp FilePath
dstFp

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)

noMatch :: [a] -> (a -> Bool) -> String -> IO ()
noMatch :: [a] -> (a -> Bool) -> FilePath -> IO ()
noMatch [] a -> Bool
_ FilePath
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
noMatch [a]
as a -> Bool
predicate FilePath
err = IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err) ((a -> Bool) -> [a] -> Bool
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 = [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

dontExpectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()
dontExpectCodeAction :: [Command |? CodeAction] -> [Text] -> IO ()
dontExpectCodeAction [Command |? CodeAction]
cars [Text]
s =
  [Command |? CodeAction]
-> ((Command |? CodeAction) -> Bool) -> FilePath -> IO ()
forall a. [a] -> (a -> Bool) -> FilePath -> IO ()
noMatch [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
"didn't 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 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 ((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'