{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE OverloadedStrings     #-}
module Test.Hls
  ( module Test.Tasty.HUnit,
    module Test.Tasty,
    module Test.Tasty.ExpectedFailure,
    module Test.Hls.Util,
    module Language.LSP.Protocol.Types,
    module Language.LSP.Protocol.Message,
    module Language.LSP.Test,
    module Control.Monad.IO.Class,
    module Control.Applicative.Combinators,
    defaultTestRunner,
    goldenGitDiff,
    goldenWithHaskellDoc,
    goldenWithHaskellDocInTmpDir,
    goldenWithHaskellAndCaps,
    goldenWithHaskellAndCapsInTmpDir,
    goldenWithCabalDoc,
    goldenWithHaskellDocFormatter,
    goldenWithHaskellDocFormatterInTmpDir,
    goldenWithCabalDocFormatter,
    goldenWithCabalDocFormatterInTmpDir,
    def,
    -- * Running HLS for integration tests
    runSessionWithServer,
    runSessionWithServerAndCaps,
    runSessionWithServerInTmpDir,
    runSessionWithServerAndCapsInTmpDir,
    runSessionWithServer',
    runSessionWithServerInTmpDir',
    -- * Helpful re-exports
    PluginDescriptor,
    IdeState,
    -- * Assertion helper functions
    waitForProgressDone,
    waitForAllProgressDone,
    waitForBuildQueue,
    waitForTypecheck,
    waitForAction,
    hlsConfigToClientConfig,
    setHlsConfig,
    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.Lens.Extras                (is)
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           Data.Proxy                         (Proxy (Proxy))
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.Options
import           GHC.IO.Handle
import           GHC.Stack                          (emptyCallStack)
import           GHC.TypeLits
import           Ide.Logger                         (Doc, Logger (Logger),
                                                     Pretty (pretty),
                                                     Priority (..),
                                                     Recorder (Recorder, logger_),
                                                     WithPriority (WithPriority, priority),
                                                     cfilter, cmapWithPrio,
                                                     logWith,
                                                     makeDefaultStderrRecorder,
                                                     (<+>))
import           Ide.Types
import           Language.LSP.Protocol.Capabilities
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types        hiding (Null)
import           Language.LSP.Test
import           Prelude                            hiding (log)
import           System.Directory                   (getCurrentDirectory,
                                                     setCurrentDirectory)
import           System.Environment                 (lookupEnv)
import           System.FilePath
import           System.IO.Extra                    (newTempDir, withTempDir)
import           System.IO.Unsafe                   (unsafePerformIO)
import           System.Process.Extra               (createPipe)
import           System.Time.Extra
import qualified Test.Hls.FileSystem                as FS
import           Test.Hls.FileSystem
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

data Log
  = LogIDEMain IDEMain.Log
  | LogTestHarness LogTestHarness

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

data LogTestHarness
  = LogTestDir FilePath
  | LogCleanup
  | LogNoCleanup


instance Pretty LogTestHarness where
  pretty :: forall ann. LogTestHarness -> Doc ann
pretty = \case
    LogTestDir String
dir -> Doc ann
"Test Project located in directory:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
dir
    LogTestHarness
LogCleanup     -> Doc ann
"Cleaned up temporary directory"
    LogTestHarness
LogNoCleanup   -> Doc ann
"No cleanup of temporary directory"

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

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

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

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

goldenWithHaskellDocInTmpDir
  :: Pretty b
  => Config
  -> PluginTestDescriptor b
  -> TestName
  -> VirtualFileTree
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDocInTmpDir :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocInTmpDir = Text
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDocInTmpDir Text
"haskell"

goldenWithHaskellAndCaps
  :: Pretty b
  => Config
  -> ClientCapabilities
  -> PluginTestDescriptor b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellAndCaps :: forall b.
Pretty b =>
Config
-> ClientCapabilities
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCaps Config
config ClientCapabilities
clientCaps PluginTestDescriptor b
plugin String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> String
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServerAndCaps Config
config PluginTestDescriptor b
plugin ClientCapabilities
clientCaps String
testDataDir
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    Session Seconds -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

goldenWithHaskellAndCapsInTmpDir
  :: Pretty b
  => Config
  -> ClientCapabilities
  -> PluginTestDescriptor b
  -> TestName
  -> VirtualFileTree
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellAndCapsInTmpDir :: forall b.
Pretty b =>
Config
-> ClientCapabilities
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCapsInTmpDir Config
config ClientCapabilities
clientCaps PluginTestDescriptor b
plugin String
title VirtualFileTree
tree String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (VirtualFileTree -> String
vftOriginalRoot VirtualFileTree
tree String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> VirtualFileTree
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> VirtualFileTree
-> Session a
-> IO a
runSessionWithServerAndCapsInTmpDir Config
config PluginTestDescriptor b
plugin ClientCapabilities
clientCaps VirtualFileTree
tree
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    Session Seconds -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

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

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

goldenWithDocInTmpDir
  :: Pretty b
  => T.Text
  -> Config
  -> PluginTestDescriptor b
  -> TestName
  -> VirtualFileTree
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithDocInTmpDir :: forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDocInTmpDir Text
fileType Config
config PluginTestDescriptor b
plugin String
title VirtualFileTree
tree String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (VirtualFileTree -> String
vftOriginalRoot VirtualFileTree
tree String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> VirtualFileTree
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
runSessionWithServerInTmpDir Config
config PluginTestDescriptor b
plugin VirtualFileTree
tree
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
fileType
    Session Seconds -> Session ()
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 = [PluginDescriptor IdeState] -> IdePlugins IdeState
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 = [PluginDescriptor IdeState] -> IdePlugins IdeState
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 ()
_) <- [String]
-> IO (Recorder (WithPriority a), WithPriority (Doc Any) -> IO ())
forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [String
Item [String]
"HLS_TEST_PLUGIN_LOG_STDERR", String
Item [String]
"HLS_TEST_LOG_STDERR"]
  Recorder (WithPriority a) -> IO (Recorder (WithPriority a))
forall a. a -> IO a
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 =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [String]
envVars = do
    Recorder (WithPriority (Doc ann))
docWithPriorityRecorder <- Maybe [LoggingColumn] -> IO (Recorder (WithPriority (Doc ann)))
forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder Maybe [LoggingColumn]
forall a. Maybe a
Nothing
    -- There are potentially multiple environment variables that enable this logger
    [String]
definedEnvVars <- [String] -> (String -> IO String) -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
envVars (\String
var -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"0" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
var)
    let logStdErr :: Bool
logStdErr = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0") [String]
definedEnvVars

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

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

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

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

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

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

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

runSessionWithServerAndCapsInTmpDir :: Pretty b => Config ->  PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a
runSessionWithServerAndCapsInTmpDir :: forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> VirtualFileTree
-> Session a
-> IO a
runSessionWithServerAndCapsInTmpDir Config
config PluginTestDescriptor b
plugin ClientCapabilities
caps VirtualFileTree
tree Session a
act = do
  Recorder (WithPriority b)
recorder <- IO (Recorder (WithPriority b))
forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> VirtualFileTree
-> Session a
-> IO a
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> VirtualFileTree
-> Session a
-> IO a
runSessionWithServerInTmpDir' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) Config
config SessionConfig
forall a. Default a => a
def ClientCapabilities
caps VirtualFileTree
tree Session a
act

-- | Host a server, and run a test session on it.
--
-- Creates a temporary directory, and materializes the VirtualFileTree
-- in the temporary directory.
--
-- To debug test cases and verify the file system is correctly set up,
-- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.
-- Further, we log the temporary directory location on startup. To view
-- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.
--
-- Example invocation to debug test cases:
--
-- @
--   HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>
-- @
--
-- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.
--
-- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.
--
-- Note: cwd will be shifted into a temporary directory in @Session a@
runSessionWithServerInTmpDir' ::
  -- | 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 ->
  VirtualFileTree ->
  Session a ->
  IO a
runSessionWithServerInTmpDir' :: forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> VirtualFileTree
-> Session a
-> IO a
runSessionWithServerInTmpDir' IdePlugins IdeState
plugins Config
conf SessionConfig
sessConf ClientCapabilities
caps VirtualFileTree
tree Session a
act = Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
withLock Lock
lockForTempDirs (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  (Recorder (WithPriority LogTestHarness)
recorder, WithPriority (Doc Any) -> IO ()
_) <- [String]
-> IO
     (Recorder (WithPriority LogTestHarness),
      WithPriority (Doc Any) -> IO ())
forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder
    [String
Item [String]
"LSP_TEST_LOG_STDERR", String
Item [String]
"HLS_TEST_HARNESS_STDERR", String
Item [String]
"HLS_TEST_LOG_STDERR"]

  -- Do not clean up the temporary directory if this variable is set to anything but '0'.
  -- Aids debugging.
  Maybe String
cleanupTempDir <- String -> IO (Maybe String)
lookupEnv String
"HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP"
  let runTestInDir :: (String -> IO a) -> IO a
runTestInDir = case Maybe String
cleanupTempDir of
        Just String
val
          | String
val String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0" -> \String -> IO a
action -> do
            (String
tempDir, IO ()
_) <- IO (String, IO ())
newTempDir
            a
a <- String -> IO a
action String
tempDir
            Recorder (WithPriority LogTestHarness)
-> Priority -> LogTestHarness -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogTestHarness)
recorder Priority
Debug LogTestHarness
LogNoCleanup
            a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

        Maybe String
_ -> \String -> IO a
action -> do
          a
a <- (String -> IO a) -> IO a
forall a. (String -> IO a) -> IO a
withTempDir String -> IO a
action
          Recorder (WithPriority LogTestHarness)
-> Priority -> LogTestHarness -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogTestHarness)
recorder Priority
Debug LogTestHarness
LogCleanup
          a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

  (String -> IO a) -> IO a
runTestInDir ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
tmpDir -> do
    Recorder (WithPriority LogTestHarness)
-> Priority -> LogTestHarness -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogTestHarness)
recorder Priority
Info (LogTestHarness -> IO ()) -> LogTestHarness -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LogTestHarness
LogTestDir String
tmpDir
    FileSystem
_fs <- String -> VirtualFileTree -> IO FileSystem
FS.materialiseVFT String
tmpDir VirtualFileTree
tree
    IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' IdePlugins IdeState
plugins Config
conf SessionConfig
sessConf ClientCapabilities
caps String
tmpDir Session a
act

goldenWithHaskellDocFormatter
  :: Pretty b
  => Config
  -> 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 =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  let config' :: Config
config' = Config
config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
  in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> String
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config' PluginTestDescriptor b
plugin String
testDataDir
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    Session Seconds -> Session ()
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
  => Config
  -> 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 =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  let config' :: Config
config' = Config
config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
  in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> String
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config' PluginTestDescriptor b
plugin String
testDataDir
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"cabal"
    Session Seconds -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

goldenWithHaskellDocFormatterInTmpDir
  :: Pretty b
  => Config
  -> PluginTestDescriptor b -- ^ Formatter plugin to be used
  -> String -- ^ Name of the formatter to be used
  -> PluginConfig
  -> TestName -- ^ Title of the test
  -> VirtualFileTree -- ^ Virtual representation of the test project
  -> 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
goldenWithHaskellDocFormatterInTmpDir :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatterInTmpDir Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title VirtualFileTree
tree String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  let config' :: Config
config' = Config
config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
  in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (VirtualFileTree -> String
vftOriginalRoot VirtualFileTree
tree String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> VirtualFileTree
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
runSessionWithServerInTmpDir Config
config' PluginTestDescriptor b
plugin VirtualFileTree
tree
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    Session Seconds -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

goldenWithCabalDocFormatterInTmpDir
  :: Pretty b
  => Config
  -> PluginTestDescriptor b -- ^ Formatter plugin to be used
  -> String -- ^ Name of the formatter to be used
  -> PluginConfig
  -> TestName -- ^ Title of the test
  -> VirtualFileTree -- ^ Virtual representation of the test project
  -> 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
goldenWithCabalDocFormatterInTmpDir :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatterInTmpDir Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title VirtualFileTree
tree String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
  let config' :: Config
config' = Config
config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
  in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (VirtualFileTree -> String
vftOriginalRoot VirtualFileTree
tree String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ Config
-> PluginTestDescriptor b
-> VirtualFileTree
-> Session ByteString
-> IO ByteString
forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
runSessionWithServerInTmpDir Config
config' PluginTestDescriptor b
plugin VirtualFileTree
tree
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"cabal"
    Session Seconds -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

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

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


{-# NOINLINE lockForTempDirs #-}
-- | Never run in parallel
lockForTempDirs :: Lock
lockForTempDirs :: Lock
lockForTempDirs = IO 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
-> String
-> Session a
-> IO a
runSessionWithServer' IdePlugins IdeState
plugins Config
conf SessionConfig
sconf ClientCapabilities
caps String
root Session a
s =  Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
keepCurrentDirectory (IO a -> IO a) -> IO a -> IO a
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_) <- [String]
-> IO
     (Recorder (WithPriority Log), WithPriority (Doc Any) -> IO ())
forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder
      [String
Item [String]
"LSP_TEST_LOG_STDERR", String
Item [String]
"HLS_TEST_SERVER_LOG_STDERR", String
Item [String]
"HLS_TEST_LOG_STDERR"]

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

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

        arguments :: Arguments
arguments@Arguments{ Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, IO Logger
argsLogger :: IO Logger
argsLogger :: Arguments -> IO Logger
argsLogger } =
            Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
testing ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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 True
                    , optCheckProject = pure False
                    }

    Async ()
server <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
        Recorder (WithPriority Log) -> Arguments -> IO ()
Ghcide.defaultMain ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder)
            Arguments
arguments
                { argsHandleIn = pure inR
                , argsHandleOut = pure outW
                , argsDefaultHlsConfig = conf
                , argsLogger = argsLogger
                , argsIdeOptions = ideOptions
                , argsProjectRoot = Just root
                }

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

-- | Wait for the next progress end step
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe ()) -> Session ()
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe ()) -> Session ())
-> (FromServerMessage -> Maybe ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess  SMethod m
SMethod_Progress  (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
-> Value -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v-> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> Maybe ()
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
      ~() <- Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe ()) -> Session ()
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe ()) -> Session ())
-> (FromServerMessage -> Maybe ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess  SMethod m
SMethod_Progress  (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
-> Value -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> Maybe ()
forall a. Maybe a
Nothing
      Bool
done <- Set ProgressToken -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set ProgressToken -> Bool)
-> Session (Set ProgressToken) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      Bool -> Session () -> Session ()
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 ('Method_CustomMethod "test")
m = Proxy "test" -> SMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m (TestRequest -> Value
forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, TResponseMessage ('Method_CustomMethod "test")
resp) <- Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session
     (Seconds, TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session
      (Seconds, TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session
     (Seconds, TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ Session FromServerMessage
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session (TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m LspId ('Method_CustomMethod "test")
waitId
    case TResponseMessage ('Method_CustomMethod "test")
resp of
        TResponseMessage{$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result=Right Value
MessageResult ('Method_CustomMethod "test")
Null} -> Seconds -> Session Seconds
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        TResponseMessage ('Method_CustomMethod "test")
_                                    -> Seconds -> Session Seconds
forall a. a -> Session a
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 ('Method_CustomMethod "test")
cm = Proxy "test" -> SMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (TestRequest -> Value
forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    TResponseMessage{Either ResponseError (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result :: Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result} <- Session FromServerMessage
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session (TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
waitId
    Either ResponseError b -> Session (Either ResponseError b)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError b -> Session (Either ResponseError b))
-> Either ResponseError b -> Session (Either ResponseError b)
forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either ResponseError Value
Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result
      case Value -> Result b
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
        A.Error String
err -> ResponseError -> Either ResponseError b
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError b)
-> ResponseError -> Either ResponseError b
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) (String -> Text
T.pack String
err) Maybe Value
forall a. Maybe a
Nothing
        A.Success b
a -> b -> Either ResponseError b
forall a. a -> Either ResponseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

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

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

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

hlsConfigToClientConfig :: Config -> A.Object
hlsConfigToClientConfig :: Config -> Object
hlsConfigToClientConfig Config
config = [(Key
"haskell", Config -> Value
forall a. ToJSON a => a -> Value
toJSON Config
config)]

-- | Set the HLS client configuration, and wait for the server to update to use it.
-- Note that this will only work if we are not ignoring configuration requests, you
-- may need to call @setIgnoringConfigurationRequests False@ first.
setHlsConfig :: Config -> Session ()
setHlsConfig :: Config -> Session ()
setHlsConfig Config
config = do
  Object -> Session ()
setConfig (Object -> Session ()) -> Object -> Session ()
forall a b. (a -> b) -> a -> b
$ Config -> Object
hlsConfigToClientConfig Config
config
  -- wait until we get the workspace/configuration request from the server, so
  -- we know things are settling. This only works if we're not skipping config
  -- requests!
  Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session FromServerMessage -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
configurationRequest)

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

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

nonTrivialKickDone :: Session ()
nonTrivialKickDone :: Session ()
nonTrivialKickDone = Proxy "kick/done" -> Session [String]
forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"kick/done") Session [String] -> ([String] -> Session ()) -> Session ()
forall a b. Session a -> (a -> Session b) -> Session b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Session ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Session ())
-> ([String] -> Bool) -> [String] -> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

nonTrivialKickStart :: Session ()
nonTrivialKickStart :: Session ()
nonTrivialKickStart = Proxy "kick/start" -> Session [String]
forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"kick/start") Session [String] -> ([String] -> Session ()) -> Session ()
forall a b. Session a -> (a -> Session b) -> Session b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Session ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Session ())
-> ([String] -> Bool) -> [String] -> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

kick :: KnownSymbol k => Proxy k -> Session [FilePath]
kick :: forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick Proxy k
proxyMsg = do
  NotMess TNotificationMessage{MessageParams ('Method_CustomMethod k)
_params :: MessageParams ('Method_CustomMethod k)
$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params} <- Proxy k -> Session (TMessage ('Method_CustomMethod k))
forall (s :: Symbol).
KnownSymbol s =>
Proxy s -> Session (TMessage ('Method_CustomMethod s))
customNotification Proxy k
proxyMsg
  case Value -> Result [String]
forall a. FromJSON a => Value -> Result a
fromJSON Value
MessageParams ('Method_CustomMethod k)
_params of
    Success [String]
x -> [String] -> Session [String]
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x
    Result [String]
other     -> String -> Session [String]
forall a. HasCallStack => String -> a
error (String -> Session [String]) -> String -> Session [String]
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse kick/done details: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Result [String] -> String
forall a. Show a => a -> String
show Result [String]
other