{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PolyKinds                #-}
module Test.Hls
  ( module Test.Tasty.HUnit,
    module Test.Tasty,
    module Test.Tasty.ExpectedFailure,
    module Test.Hls.Util,
    module Language.LSP.Types,
    module Language.LSP.Test,
    module Control.Monad.IO.Class,
    module Control.Applicative.Combinators,
    defaultTestRunner,
    goldenGitDiff,
    goldenWithHaskellDoc,
    goldenWithCabalDoc,
    goldenWithHaskellDocFormatter,
    goldenWithCabalDocFormatter,
    def,
    -- * Running HLS for integration tests
    runSessionWithServer,
    runSessionWithServerAndCaps,
    runSessionWithServerFormatter,
    runSessionWithCabalServerFormatter,
    runSessionWithServer',
    -- * Helpful re-exports
    PluginDescriptor,
    IdeState,
    -- * Assertion helper functions
    waitForProgressDone,
    waitForAllProgressDone,
    waitForBuildQueue,
    waitForTypecheck,
    waitForAction,
    sendConfigurationChanged,
    getLastBuildKeys,
    waitForKickDone,
    waitForKickStart,
    -- * Plugin descriptor helper functions for tests
    PluginTestDescriptor,
    pluginTestRecorder,
    mkPluginTestDescriptor,
    mkPluginTestDescriptor',
    -- * Re-export logger types
    -- Avoids slightly annoying ghcide imports when they are unnecessary.
    WithPriority(..),
    Recorder,
    Priority(..),
    )
where

import           Control.Applicative.Combinators
import           Control.Concurrent.Async        (async, cancel, wait)
import           Control.Concurrent.Extra
import           Control.Exception.Base
import           Control.Monad                   (guard, unless, void)
import           Control.Monad.Extra             (forM)
import           Control.Monad.IO.Class
import           Data.Aeson                      (Result (Success),
                                                  Value (Null), fromJSON,
                                                  toJSON)
import qualified Data.Aeson                      as A
import           Data.ByteString.Lazy            (ByteString)
import           Data.Default                    (def)
import qualified Data.Map                        as M
import           Data.Maybe                      (fromMaybe)
import qualified Data.Text                       as T
import qualified Data.Text.Lazy                  as TL
import qualified Data.Text.Lazy.Encoding         as TL
import           Development.IDE                 (IdeState)
import           Development.IDE.Main            hiding (Log)
import qualified Development.IDE.Main            as Ghcide
import qualified Development.IDE.Main            as IDEMain
import           Development.IDE.Plugin.Test     (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
                                                  WaitForIdeRuleResult (ideResultSuccess))
import qualified Development.IDE.Plugin.Test     as Test
import           Development.IDE.Types.Logger    (Doc, Logger (Logger),
                                                  Pretty (pretty),
                                                  Priority (Debug),
                                                  Recorder (Recorder, logger_),
                                                  WithPriority (WithPriority, priority),
                                                  cfilter, cmapWithPrio,
                                                  makeDefaultStderrRecorder)
import           Development.IDE.Types.Options
import           GHC.IO.Handle
import           GHC.Stack                       (emptyCallStack)
import           Ide.Types
import           Language.LSP.Test
import           Language.LSP.Types              hiding
                                                 (SemanticTokenAbsolute (length, line),
                                                  SemanticTokenRelative (length),
                                                  SemanticTokensEdit (_start))
import           Language.LSP.Types.Capabilities (ClientCapabilities)
import           Prelude                         hiding (log)
import           System.Directory                (getCurrentDirectory,
                                                  setCurrentDirectory)
import           System.Environment              (lookupEnv)
import           System.FilePath
import           System.IO.Unsafe                (unsafePerformIO)
import           System.Process.Extra            (createPipe)
import           System.Time.Extra
import           Test.Hls.Util
import           Test.Tasty                      hiding (Timeout)
import           Test.Tasty.ExpectedFailure
import           Test.Tasty.Golden
import           Test.Tasty.HUnit
import           Test.Tasty.Ingredients.Rerun
import           Test.Tasty.Runners              (NumThreads (..))

newtype Log = LogIDEMain IDEMain.Log

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogIDEMain Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log

-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = TestTree -> IO ()
defaultMainWithRerun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int -> NumThreads
NumThreads Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Integer -> Timeout
mkTimeout Integer
600000000)

gitDiff :: FilePath -> FilePath -> [String]
gitDiff :: FilePath -> FilePath -> [FilePath]
gitDiff FilePath
fRef FilePath
fNew = [FilePath
"git", FilePath
"-c", FilePath
"core.fileMode=false", FilePath
"diff", FilePath
"--no-index", FilePath
"--text", FilePath
"--exit-code", FilePath
fRef, FilePath
fNew]

goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff :: FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
name = FilePath
-> (FilePath -> FilePath -> [FilePath])
-> FilePath
-> IO ByteString
-> TestTree
goldenVsStringDiff FilePath
name FilePath -> FilePath -> [FilePath]
gitDiff

goldenWithHaskellDoc
  :: Pretty b
  => PluginTestDescriptor b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDoc :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc = forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"haskell"

goldenWithCabalDoc
  :: Pretty b
  => PluginTestDescriptor b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithCabalDoc :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDoc = forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"cabal"

goldenWithDoc
  :: Pretty b
  => T.Text
  -> PluginTestDescriptor b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithDoc :: forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
fileType PluginTestDescriptor b
plugin FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
  FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer PluginTestDescriptor b
plugin FilePath
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
fileType
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

-- ------------------------------------------------------------
-- Helper function for initialising plugins under test
-- ------------------------------------------------------------

-- | Plugin under test where a fitting recorder is injected.
type PluginTestDescriptor b = Recorder (WithPriority b) -> IdePlugins IdeState

-- | Wrap a plugin you want to test, and inject a fitting recorder as required.
--
-- If you want to write the logs to stderr, run your tests with
-- "HLS_TEST_PLUGIN_LOG_STDERR=1", e.g.
--
-- @
--   HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test <test-suite-of-plugin>
-- @
--
--
-- To write all logs to stderr, including logs of the server, use:
--
-- @
--   HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin>
-- @
mkPluginTestDescriptor
  :: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState)
  -> PluginId
  -> PluginTestDescriptor b
mkPluginTestDescriptor :: forall b.
(Recorder (WithPriority b)
 -> PluginId -> PluginDescriptor IdeState)
-> PluginId -> PluginTestDescriptor b
mkPluginTestDescriptor Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId Recorder (WithPriority b)
recorder = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState
pluginDesc Recorder (WithPriority b)
recorder PluginId
plId]

-- | Wrap a plugin you want to test.
--
-- Ideally, try to migrate this plugin to co-log logger style architecture.
-- Therefore, you should prefer 'mkPluginTestDescriptor' to this if possible.
mkPluginTestDescriptor'
  :: (PluginId -> PluginDescriptor IdeState)
  -> PluginId
  -> PluginTestDescriptor b
mkPluginTestDescriptor' :: forall b.
(PluginId -> PluginDescriptor IdeState)
-> PluginId -> PluginTestDescriptor b
mkPluginTestDescriptor' PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId Recorder (WithPriority b)
_recorder = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId]

-- | Initialise a recorder that can be instructed to write to stderr by
-- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before
-- running the tests.
--
-- On the cli, use for example:
--
-- @
--   HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test <test-suite-of-plugin>
-- @
--
-- To write all logs to stderr, including logs of the server, use:
--
-- @
--   HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin>
-- @
pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder :: forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder = do
  (Recorder (WithPriority a)
recorder, WithPriority (Doc Any) -> IO ()
_) <- forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [FilePath
"HLS_TEST_PLUGIN_LOG_STDERR", FilePath
"HLS_TEST_LOG_STDERR"]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Recorder (WithPriority a)
recorder

-- | Generic recorder initialisation for plugins and the HLS server for test-cases.
--
-- The created recorder writes to stderr if any of the given environment variables
-- have been set to a value different to @0@.
-- We allow multiple values, to make it possible to define a single environment variable
-- that instructs all recorders in the test-suite to write to stderr.
--
-- We have to return the base logger function for HLS server logging initialisation.
-- See 'runSessionWithServer'' for details.
initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder :: forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [FilePath]
envVars = do
    Recorder (WithPriority (Doc ann))
docWithPriorityRecorder <- forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder forall a. Maybe a
Nothing
    -- There are potentially multiple environment variables that enable this logger
    [FilePath]
definedEnvVars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
envVars (\FilePath
var -> forall a. a -> Maybe a -> a
fromMaybe FilePath
"0" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
var)
    let logStdErr :: Bool
logStdErr = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/= FilePath
"0") [FilePath]
definedEnvVars

        docWithFilteredPriorityRecorder :: Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder =
          if Bool
logStdErr then forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter (\WithPriority{ Priority
priority :: Priority
priority :: forall a. WithPriority a -> Priority
priority } -> Priority
priority forall a. Ord a => a -> a -> Bool
>= Priority
Debug) Recorder (WithPriority (Doc ann))
docWithPriorityRecorder
          else forall a. Monoid a => a
mempty

        Recorder {forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_} = Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a ann. Pretty a => a -> Doc ann
pretty Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder, forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_)

-- ------------------------------------------------------------
-- Run an HLS server testing a specific plugin
-- ------------------------------------------------------------

runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer :: forall b a.
Pretty b =>
PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer PluginTestDescriptor b
plugin FilePath
fp Session a
act = do
  Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) forall a. Default a => a
def forall a. Default a => a
def ClientCapabilities
fullCaps FilePath
fp Session a
act

runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps PluginTestDescriptor b
plugin ClientCapabilities
caps FilePath
fp Session a
act = do
  Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) forall a. Default a => a
def forall a. Default a => a
def ClientCapabilities
caps FilePath
fp Session a
act

runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
fp Session a
act = do
  Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
    (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder)
    forall a. Default a => a
def
      { formattingProvider :: Text
formattingProvider = FilePath -> Text
T.pack FilePath
formatter
      , plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
      }
    forall a. Default a => a
def
    ClientCapabilities
fullCaps
    FilePath
fp
    Session a
act

goldenWithHaskellDocFormatter
  :: Pretty b
  => PluginTestDescriptor b -- ^ Formatter plugin to be used
  -> String -- ^ Name of the formatter to be used
  -> PluginConfig
  -> TestName -- ^ Title of the test
  -> FilePath -- ^ Directory of the test data to be used
  -> FilePath -- ^ Path to the testdata to be used within the directory
  -> FilePath -- ^ Additional suffix to be appended to the output file
  -> FilePath -- ^ Extension of the output file
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDocFormatter :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> PluginConfig
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
  FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

goldenWithCabalDocFormatter
  :: Pretty b
  => PluginTestDescriptor b -- ^ Formatter plugin to be used
  -> String -- ^ Name of the formatter to be used
  -> PluginConfig
  -> TestName -- ^ Title of the test
  -> FilePath -- ^ Directory of the test data to be used
  -> FilePath -- ^ Path to the testdata to be used within the directory
  -> FilePath -- ^ Additional suffix to be appended to the output file
  -> FilePath -- ^ Extension of the output file
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithCabalDocFormatter :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> PluginConfig
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
  FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"cabal"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
fp Session a
act = do
  Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
    (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder)
    forall a. Default a => a
def
      { cabalFormattingProvider :: Text
cabalFormattingProvider = FilePath -> Text
T.pack FilePath
formatter
      , plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
      }
    forall a. Default a => a
def
    ClientCapabilities
fullCaps
    FilePath
fp Session a
act

-- | Restore cwd after running an action
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory :: forall a. IO a -> IO a
keepCurrentDirectory = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
getCurrentDirectory FilePath -> IO ()
setCurrentDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

{-# NOINLINE lock #-}
-- | Never run in parallel
lock :: Lock
lock :: Lock
lock = forall a. IO a -> a
unsafePerformIO IO Lock
newLock

-- | Host a server, and run a test session on it
-- Note: cwd will be shifted into @root@ in @Session a@
runSessionWithServer' ::
  -- | Plugins to load on the server.
  --
  -- For improved logging, make sure these plugins have been initalised with
  -- the recorder produced by @pluginTestRecorder@.
  IdePlugins IdeState ->
  -- | lsp config for the server
  Config ->
  -- | config for the test session
  SessionConfig ->
  ClientCapabilities ->
  FilePath ->
  Session a ->
  IO a
runSessionWithServer' :: forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' IdePlugins IdeState
plugins Config
conf SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s = forall a. Lock -> IO a -> IO a
withLock Lock
lock forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
keepCurrentDirectory forall a b. (a -> b) -> a -> b
$ do
    (Handle
inR, Handle
inW) <- IO (Handle, Handle)
createPipe
    (Handle
outR, Handle
outW) <- IO (Handle, Handle)
createPipe

    -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before,
    -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it
    -- uses a more descriptive name.
    -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR".
    -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins
    -- under test.
    (Recorder (WithPriority Log)
recorder, WithPriority (Doc Any) -> IO ()
logger_) <- forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder
      [FilePath
"LSP_TEST_LOG_STDERR", FilePath
"HLS_TEST_SERVER_LOG_STDERR", FilePath
"HLS_TEST_LOG_STDERR"]

    let
        -- exists until old logging style is phased out
        logger :: Logger
logger = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> WithPriority (Doc Any) -> IO ()
logger_ (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack (forall a ann. Pretty a => a -> Doc ann
pretty Text
m))

        hlsPlugins :: IdePlugins IdeState
hlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command"] forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
plugins

        arguments :: Arguments
arguments@Arguments{ Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, IO Logger
argsLogger :: Arguments -> IO Logger
argsLogger :: IO Logger
argsLogger } =
            Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
testing (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Logger
logger IdePlugins IdeState
hlsPlugins

        ideOptions :: Config -> Action IdeGhcSession -> IdeOptions
ideOptions Config
config Action IdeGhcSession
ghcSession =
            let defIdeOptions :: IdeOptions
defIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
ghcSession
            in IdeOptions
defIdeOptions
                    { optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True
                    , optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    }

    Async ()
server <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$
        Recorder (WithPriority Log) -> Arguments -> IO ()
Ghcide.defaultMain (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder)
            Arguments
arguments
                { argsHandleIn :: IO Handle
argsHandleIn = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
inR
                , argsHandleOut :: IO Handle
argsHandleOut = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
outW
                , argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
conf
                , argsLogger :: IO Logger
argsLogger = IO Logger
argsLogger
                , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
ideOptions
                }

    a
x <- forall a.
Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithHandles Handle
inW Handle
outR SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s
    Handle -> IO ()
hClose Handle
inW
    forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
3 (forall a. Async a -> IO a
wait Async ()
server) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe ()
Nothing -> do
            FilePath -> IO ()
putStrLn FilePath
"Server does not exit in 3s, canceling the async task..."
            (Seconds
t, ()
_) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
cancel Async ()
server
            FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Finishing canceling (took " forall a. Semigroup a => a -> a -> a
<> Seconds -> FilePath
showDuration Seconds
t forall a. Semigroup a => a -> a -> a
<> FilePath
"s)"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Wait for the next progress end step
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
SProgress (NotificationMessage Text
_ SMethod 'Progress
_ (ProgressParams ProgressToken
_ (End WorkDoneProgressEndParams
_))) -> forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForAllProgressDone :: Session ()
waitForAllProgressDone :: Session ()
waitForAllProgressDone = Session ()
loop
  where
    loop :: Session ()
loop = do
      ~() <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess SMethod m
SProgress (NotificationMessage Text
_ SMethod 'Progress
_ (ProgressParams ProgressToken
_ (End WorkDoneProgressEndParams
_))) -> forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> forall a. Maybe a
Nothing
      Bool
done <- forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done Session ()
loop

-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
    let m :: SMethod 'CustomMethod
m = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m (forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, ResponseMessage 'CustomMethod
resp) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m LspId 'CustomMethod
waitId
    case ResponseMessage 'CustomMethod
resp of
        ResponseMessage{$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result=Right Value
ResponseResult 'CustomMethod
Null} -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        ResponseMessage 'CustomMethod
_                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
0

callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
callTestPlugin :: forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
cmd = do
    let cm :: SMethod 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    ResponseMessage{Either ResponseError (ResponseResult 'CustomMethod)
_result :: Either ResponseError (ResponseResult 'CustomMethod)
$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result} <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
waitId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either ResponseError (ResponseResult 'CustomMethod)
_result
      case forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
        A.Error FilePath
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (FilePath -> Text
T.pack FilePath
err) forall a. Maybe a
Nothing
        A.Success b
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction :: FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
    forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin (FilePath -> Uri -> TestRequest
WaitForIdeRule FilePath
key Uri
_uri)

waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck TextDocumentIdentifier
tid = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WaitForIdeRuleResult -> Bool
ideResultSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
"typecheck" TextDocumentIdentifier
tid

getLastBuildKeys :: Session (Either ResponseError [T.Text])
getLastBuildKeys :: Session (Either ResponseError [Text])
getLastBuildKeys = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
GetBuildKeysBuilt

sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged Value
config =
  forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'WorkspaceDidChangeConfiguration
SWorkspaceDidChangeConfiguration (Value -> DidChangeConfigurationParams
DidChangeConfigurationParams Value
config)

waitForKickDone :: Session ()
waitForKickDone :: Session ()
waitForKickDone = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickDone

waitForKickStart :: Session ()
waitForKickStart :: Session ()
waitForKickStart = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickStart

nonTrivialKickDone :: Session ()
nonTrivialKickDone :: Session ()
nonTrivialKickDone = Text -> Session [FilePath]
kick Text
"done" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

nonTrivialKickStart :: Session ()
nonTrivialKickStart :: Session ()
nonTrivialKickStart = Text -> Session [FilePath]
kick Text
"start" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

kick :: T.Text -> Session [FilePath]
kick :: Text -> Session [FilePath]
kick Text
msg = do
  NotMess NotificationMessage{MessageParams 'CustomMethod
$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params :: MessageParams 'CustomMethod
_params} <- Text -> Session (ServerMessage 'CustomMethod)
customNotification forall a b. (a -> b) -> a -> b
$ Text
"kick/" forall a. Semigroup a => a -> a -> a
<> Text
msg
  case forall a. FromJSON a => Value -> Result a
fromJSON MessageParams 'CustomMethod
_params of
    Success [FilePath]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
x
    Result [FilePath]
other     -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse kick/done details: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Result [FilePath]
other