{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
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,
    goldenWithTestConfig,
    def,
    -- * Running HLS for integration tests
    runSessionWithServer,
    runSessionWithServerInTmpDir,
    runSessionWithTestConfig,
    -- * Running parameterised tests for a set of test configurations
    parameterisedCursorTest,
    -- * Helpful re-exports
    PluginDescriptor,
    IdeState,
    -- * Assertion helper functions
    waitForProgressDone,
    waitForAllProgressDone,
    waitForBuildQueue,
    waitForProgressBegin,
    waitForTypecheck,
    waitForAction,
    hlsConfigToClientConfig,
    setHlsConfig,
    getLastBuildKeys,
    waitForKickDone,
    waitForKickStart,
    -- * Plugin descriptor helper functions for tests
    PluginTestDescriptor,
    hlsPluginTestRecorder,
    mkPluginTestDescriptor,
    mkPluginTestDescriptor',
    -- * Re-export logger types
    -- Avoids slightly annoying ghcide imports when they are unnecessary.
    WithPriority(..),
    Recorder,
    Priority(..),
    TestConfig(..),
    )
where

import           Control.Applicative.Combinators
import           Control.Concurrent.Async                 (async, cancel, wait)
import           Control.Concurrent.Extra
import           Control.Exception.Safe
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                             (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,
                                                           LoggingColumn (ThreadIdColumn),
                                                           defaultLayoutOptions,
                                                           layoutPretty,
                                                           renderStrict)
import           Development.IDE.Main                     hiding (Log)
import qualified Development.IDE.Main                     as IDEMain
import           Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
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.TypeLits
import           Ide.Logger                               (Pretty (pretty),
                                                           Priority (..),
                                                           Recorder,
                                                           WithPriority (WithPriority, priority),
                                                           cfilter,
                                                           cmapWithPrio,
                                                           defaultLoggingColumns,
                                                           logWith,
                                                           makeDefaultStderrRecorder,
                                                           (<+>))
import qualified Ide.Logger                               as Logger
import           Ide.PluginUtils                          (idePluginsToPluginDesc,
                                                           pluginDescToIdePlugins)
import           Ide.Types
import           Language.LSP.Protocol.Capabilities
import           Language.LSP.Protocol.Message
import qualified Language.LSP.Protocol.Message            as LSP
import           Language.LSP.Protocol.Types              hiding (Null)
import qualified Language.LSP.Server                      as LSP
import           Language.LSP.Test
import           Prelude                                  hiding (log)
import           System.Directory                         (canonicalizePath,
                                                           createDirectoryIfMissing,
                                                           getCurrentDirectory,
                                                           getTemporaryDirectory,
                                                           makeAbsolute,
                                                           setCurrentDirectory)
import           System.Environment                       (lookupEnv, setEnv)
import           System.FilePath
import           System.IO.Extra                          (newTempDirWithin)
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 = LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
forall b.
Pretty b =>
LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc LanguageKind
LanguageKind_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 = LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
forall b.
Pretty b =>
LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDocInTmpDir LanguageKind
LanguageKind_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
$ TestConfig b -> (String -> Session ByteString) -> IO ByteString
forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig Any
forall a. Default a => a
def {
    testDirLocation = Left testDataDir,
    testConfigCaps = clientCaps,
    testLspConfig = config,
    testPluginDescriptor = plugin
  }
  ((String -> Session ByteString) -> IO ByteString)
-> (String -> Session ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Session ByteString -> String -> Session ByteString
forall a b. a -> b -> a
const
--   runSessionWithServerAndCaps config plugin clientCaps testDataDir
  (Session ByteString -> String -> Session ByteString)
-> Session ByteString -> String -> Session 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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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

goldenWithTestConfig
  :: Pretty b
  => TestConfig b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithTestConfig :: forall b.
Pretty b =>
TestConfig b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithTestConfig TestConfig b
config 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
$ TestConfig b -> (String -> Session ByteString) -> IO ByteString
forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig b
config ((String -> Session ByteString) -> IO ByteString)
-> (String -> Session ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Session ByteString -> String -> Session ByteString
forall a b. a -> b -> a
const
  (Session ByteString -> String -> Session ByteString)
-> Session ByteString -> String -> Session 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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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
$
  TestConfig b -> (String -> Session ByteString) -> IO ByteString
forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig Any
forall a. Default a => a
def {
    testDirLocation = Right tree,
    testConfigCaps = clientCaps,
    testLspConfig = config,
    testPluginDescriptor = plugin
  } ((String -> Session ByteString) -> IO ByteString)
-> (String -> Session ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Session ByteString -> String -> Session ByteString
forall a b. a -> b -> a
const
  (Session ByteString -> String -> Session ByteString)
-> Session ByteString -> String -> Session 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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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 = LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
forall b.
Pretty b =>
LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc (Text -> LanguageKind
LanguageKind_Custom Text
"cabal")

goldenWithDoc
  :: Pretty b
  => LanguageKind
  -> Config
  -> PluginTestDescriptor b
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithDoc :: forall b.
Pretty b =>
LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc LanguageKind
languageKind 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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
languageKind
    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
  => LanguageKind
  -> Config
  -> PluginTestDescriptor b
  -> TestName
  -> VirtualFileTree
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithDocInTmpDir :: forall b.
Pretty b =>
LanguageKind
-> Config
-> PluginTestDescriptor b
-> String
-> VirtualFileTree
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDocInTmpDir LanguageKind
languageKind 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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
languageKind
    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

-- | A parameterised test is similar to a normal test case but allows to run
-- the same test case multiple times with different inputs.
-- A 'parameterisedCursorTest' allows to define a test case based on an input file
-- that specifies one or many cursor positions via the identification value '^'.
--
-- For example:
--
-- @
--  parameterisedCursorTest "Cursor Test" [trimming|
--       foo = 2
--        ^
--       bar = 3
--       baz = foo + bar
--         ^
--       |]
--       ["foo", "baz"]
--       (\input cursor -> findFunctionNameUnderCursor input cursor)
-- @
--
-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.
--
-- This test definition will run the test case 'findFunctionNameUnderCursor' for
-- each cursor position, each in its own isolated 'testCase'.
-- Cursor positions are identified via the character '^', which points to the
-- above line as the actual cursor position.
-- Lines containing '^' characters, are removed from the final text, that is
-- passed to the testing function.
--
-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.
-- We likely need a way to change the character for certain test cases in the future.
--
-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally
-- allows to interpolate haskell values and functions. We reexport this quasi quoter
-- for easier usage.
parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree
parameterisedCursorTest :: forall a.
(Show a, Eq a) =>
String
-> Text -> [a] -> (Text -> PosPrefixInfo -> IO a) -> TestTree
parameterisedCursorTest String
title Text
content [a]
expectations Text -> PosPrefixInfo -> IO a
act
  | Int
lenPrefs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
lenExpected = String -> TestTree
forall a. HasCallStack => String -> a
error (String -> TestTree) -> String -> TestTree
forall a b. (a -> b) -> a -> b
$ String
"parameterisedCursorTest: Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
lenExpected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" cursors but found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
lenPrefs
  | Bool
otherwise = String -> [TestTree] -> TestTree
testGroup String
title ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
      ((Int, (a, PosPrefixInfo)) -> TestTree)
-> [(Int, (a, PosPrefixInfo))] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (a, PosPrefixInfo)) -> TestTree
singleTest [(Int, (a, PosPrefixInfo))]
testCaseSpec
  where
    lenPrefs :: Int
lenPrefs = [PosPrefixInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PosPrefixInfo]
prefInfos
    lenExpected :: Int
lenExpected = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
expectations
    (Text
cleanText, [PosPrefixInfo]
prefInfos) = Text -> (Text, [PosPrefixInfo])
extractCursorPositions Text
content

    testCaseSpec :: [(Int, (a, PosPrefixInfo))]
testCaseSpec = [Int] -> [(a, PosPrefixInfo)] -> [(Int, (a, PosPrefixInfo))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ::Int ..] ([a] -> [PosPrefixInfo] -> [(a, PosPrefixInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
expectations [PosPrefixInfo]
prefInfos)

    singleTest :: (Int, (a, PosPrefixInfo)) -> TestTree
singleTest (Int
n, (a
expected, PosPrefixInfo
info)) = String -> IO () -> TestTree
testCase (String
title String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n) (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
      a
actual <- Text -> PosPrefixInfo -> IO a
act Text
cleanText PosPrefixInfo
info
      String -> a -> a -> IO ()
forall a. (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()
assertEqual (PosPrefixInfo -> String
mkParameterisedLabel PosPrefixInfo
info) a
expected a
actual

-- ------------------------------------------------------------
-- 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]

-- | Initialize a recorder that can be instructed to write to stderr by
-- setting one of the environment variables:
--
-- * HLS_TEST_HARNESS_STDERR=1
-- * HLS_TEST_LOG_STDERR=1
--
-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins
-- under test.
hlsHelperTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
hlsHelperTestRecorder :: forall a. Pretty a => IO (Recorder (WithPriority a))
hlsHelperTestRecorder = [String] -> IO (Recorder (WithPriority a))
forall a. Pretty a => [String] -> IO (Recorder (WithPriority a))
initializeTestRecorder [String
Item [String]
"HLS_TEST_HARNESS_STDERR", String
Item [String]
"HLS_TEST_LOG_STDERR"]


-- | Initialize a recorder that can be instructed to write to stderr by
-- setting one of the environment variables:
--
-- * HLS_TEST_PLUGIN_LOG_STDERR=1
-- * HLS_TEST_LOG_STDERR=1
--
-- before running the tests.
--
-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins
-- under test.
--
-- 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>
-- @
hlsPluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
hlsPluginTestRecorder :: forall a. Pretty a => IO (Recorder (WithPriority a))
hlsPluginTestRecorder = [String] -> IO (Recorder (WithPriority a))
forall a. Pretty a => [String] -> IO (Recorder (WithPriority a))
initializeTestRecorder [String
Item [String]
"HLS_TEST_PLUGIN_LOG_STDERR", String
Item [String]
"HLS_TEST_LOG_STDERR"]

-- | Generic recorder initialization 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.
initializeTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a))
initializeTestRecorder :: forall a. Pretty a => [String] -> IO (Recorder (WithPriority a))
initializeTestRecorder [String]
envVars = do
    Recorder (WithPriority (Doc Any))
docWithPriorityRecorder <- Maybe [LoggingColumn] -> IO (Recorder (WithPriority (Doc Any)))
forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder ([LoggingColumn] -> Maybe [LoggingColumn]
forall a. a -> Maybe a
Just ([LoggingColumn] -> Maybe [LoggingColumn])
-> [LoggingColumn] -> Maybe [LoggingColumn]
forall a b. (a -> b) -> a -> b
$ LoggingColumn
ThreadIdColumn LoggingColumn -> [LoggingColumn] -> [LoggingColumn]
forall a. a -> [a] -> [a]
: [LoggingColumn]
defaultLoggingColumns)
    -- lspClientLogRecorder
    -- 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 ((Maybe String -> String) -> IO (Maybe String) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"0") (IO (Maybe String) -> IO String)
-> (String -> IO (Maybe String)) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
lookupEnv)
    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 Any))
docWithFilteredPriorityRecorder =
          if Bool
logStdErr then (WithPriority (Doc Any) -> Bool)
-> Recorder (WithPriority (Doc Any))
-> Recorder (WithPriority (Doc Any))
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 Any))
docWithPriorityRecorder
          else Recorder (WithPriority (Doc Any))
forall a. Monoid a => a
mempty

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

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

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 =
    TestConfig b -> (String -> Session a) -> IO a
forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig Any
forall a. Default a => a
def
    {testLspConfig=config, testPluginDescriptor = plugin,  testDirLocation=Right tree}
    (Session a -> String -> Session a
forall a b. a -> b -> a
const Session a
act)

runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) ->  IO a
runWithLockInTempDir :: forall a. VirtualFileTree -> (FileSystem -> IO a) -> IO a
runWithLockInTempDir VirtualFileTree
tree FileSystem -> IO 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
    String
testRoot <- IO String
setupTestEnvironment
    Recorder (WithPriority LogTestHarness)
helperRecorder <- IO (Recorder (WithPriority LogTestHarness))
forall a. Pretty a => IO (Recorder (WithPriority a))
hlsHelperTestRecorder
    -- 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 String -> IO a
action = case Maybe String
cleanupTempDir of
            Just String
val | String
val String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0" -> do
                (String
tempDir, IO ()
_) <- String -> IO (String, IO ())
newTempDirWithin String
testRoot
                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)
helperRecorder 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
_ -> do
                (String
tempDir, IO ()
cleanup) <- String -> IO (String, IO ())
newTempDirWithin String
testRoot
                a
a <- String -> IO a
action String
tempDir IO a -> IO () -> IO a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IO ()
cleanup
                Recorder (WithPriority LogTestHarness)
-> Priority -> LogTestHarness -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogTestHarness)
helperRecorder 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
        -- we canonicalize the path, so that we do not need to do
        -- cannibalization during the test when we compare two paths
        String
tmpDir <- String -> IO String
canonicalizePath String
tmpDir'
        Recorder (WithPriority LogTestHarness)
-> Priority -> LogTestHarness -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority LogTestHarness)
helperRecorder 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
        FileSystem -> IO a
act FileSystem
fs

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 =
    TestConfig b -> (String -> Session a) -> IO a
forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig Any
forall a. Default a => a
def {
        testLspConfig=config
        , testPluginDescriptor=plugin
        , testDirLocation = Left fp
        } (Session a -> String -> Session a
forall a b. a -> b -> a
const Session a
act)


instance Default (TestConfig b) where
  def :: TestConfig b
def = TestConfig {
    $sel:testDirLocation:TestConfig :: Either String VirtualFileTree
testDirLocation = VirtualFileTree -> Either String VirtualFileTree
forall a b. b -> Either a b
Right (VirtualFileTree -> Either String VirtualFileTree)
-> VirtualFileTree -> Either String VirtualFileTree
forall a b. (a -> b) -> a -> b
$ [FileTree] -> String -> VirtualFileTree
VirtualFileTree [] String
"",
    $sel:testClientRoot:TestConfig :: Maybe String
testClientRoot = Maybe String
forall a. Maybe a
Nothing,
    $sel:testServerRoot:TestConfig :: Maybe String
testServerRoot = Maybe String
forall a. Maybe a
Nothing,
    $sel:testShiftRoot:TestConfig :: Bool
testShiftRoot = Bool
False,
    $sel:testDisableKick:TestConfig :: Bool
testDisableKick = Bool
False,
    $sel:testDisableDefaultPlugin:TestConfig :: Bool
testDisableDefaultPlugin = Bool
False,
    $sel:testPluginDescriptor:TestConfig :: PluginTestDescriptor b
testPluginDescriptor = PluginTestDescriptor b
forall a. Monoid a => a
mempty,
    $sel:testLspConfig:TestConfig :: Config
testLspConfig = Config
forall a. Default a => a
def,
    $sel:testConfigSession:TestConfig :: SessionConfig
testConfigSession = SessionConfig
forall a. Default a => a
def,
    $sel:testConfigCaps:TestConfig :: ClientCapabilities
testConfigCaps = ClientCapabilities
fullLatestClientCaps,
    $sel:testCheckProject:TestConfig :: Bool
testCheckProject = Bool
False
  }

-- | Setup the test environment for isolated tests.
--
-- This creates a directory in the temporary directory that will be
-- reused for running isolated tests.
-- It returns the root to the testing directory that tests should use.
-- This directory is not fully cleaned between reruns.
-- However, it is totally safe to delete the directory between runs.
--
-- Additionally, this overwrites the 'XDG_CACHE_HOME' variable to isolate
-- the tests from existing caches. 'hie-bios' and 'ghcide' honour the
-- 'XDG_CACHE_HOME' environment variable and generate their caches there.
setupTestEnvironment :: IO FilePath
setupTestEnvironment :: IO String
setupTestEnvironment = do
  String
tmpDirRoot <- IO String
getTemporaryDirectory
  let testRoot :: String
testRoot = String
tmpDirRoot String -> String -> String
</> String
"hls-test-root"
      testCacheDir :: String
testCacheDir = String
testRoot String -> String -> String
</> String
".cache"
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
testCacheDir
  String -> String -> IO ()
setEnv String
"XDG_CACHE_HOME" String
testCacheDir
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
testRoot

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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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 -> LanguageKind -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) LanguageKind
"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 (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m 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

data TestConfig b = TestConfig
  {
    forall b. TestConfig b -> Either String VirtualFileTree
testDirLocation          :: Either FilePath VirtualFileTree
    -- ^ Client capabilities
    -- ^ The file tree to use for the test, either a directory or a virtual file tree
    -- if using a virtual file tree,
    -- 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'.
  , forall b. TestConfig b -> Bool
testShiftRoot            :: Bool
    -- ^ Whether to shift the current directory to the root of the project
  , forall b. TestConfig b -> Maybe String
testClientRoot           :: Maybe FilePath
    -- ^ Specify the root of (the client or LSP context),
    -- if Nothing it is the same as the testDirLocation
    -- if Just, it is subdirectory of the testDirLocation
  , forall b. TestConfig b -> Maybe String
testServerRoot           :: Maybe FilePath
    -- ^ Specify root of the server, in exe, it can be specify in command line --cwd,
    -- or just the server start directory
    -- if Nothing it is the same as the testDirLocation
    -- if Just, it is subdirectory of the testDirLocation
  , forall b. TestConfig b -> Bool
testDisableKick          :: Bool
    -- ^ Whether to disable the kick action
  , forall b. TestConfig b -> Bool
testDisableDefaultPlugin :: Bool
    -- ^ Whether to disable the default plugin comes with ghcide
  , forall b. TestConfig b -> Bool
testCheckProject         :: Bool
    -- ^ Whether to typecheck check the project after the session is loaded
  , forall b. TestConfig b -> PluginTestDescriptor b
testPluginDescriptor     :: PluginTestDescriptor b
    -- ^ Plugin to load on the server.
  , forall b. TestConfig b -> Config
testLspConfig            :: Config
    -- ^ lsp config for the server
  , forall b. TestConfig b -> SessionConfig
testConfigSession        :: SessionConfig
    -- ^ config for the test session
  , forall b. TestConfig b -> ClientCapabilities
testConfigCaps           :: ClientCapabilities
    -- ^ Client capabilities
  }


wrapClientLogger :: Pretty a => Recorder (WithPriority a) ->
    IO (Recorder (WithPriority a), LSP.LanguageContextEnv Config -> IO ())
wrapClientLogger :: forall a.
Pretty a =>
Recorder (WithPriority a)
-> IO
     (Recorder (WithPriority a), LanguageContextEnv Config -> IO ())
wrapClientLogger Recorder (WithPriority a)
logger = do
    (Recorder (WithPriority Text)
lspLogRecorder', LanguageContextEnv Config -> IO ()
cb1) <- (LanguageContextEnv Config -> Recorder (WithPriority Text))
-> IO
     (Recorder (WithPriority Text), LanguageContextEnv Config -> IO ())
forall v a. (v -> Recorder a) -> IO (Recorder a, v -> IO ())
Logger.withBacklog LanguageContextEnv Config -> Recorder (WithPriority Text)
forall config.
LanguageContextEnv config -> Recorder (WithPriority Text)
Logger.lspClientLogRecorder
    let lspLogRecorder :: Recorder (WithPriority a)
lspLogRecorder = (a -> Text)
-> Recorder (WithPriority Text) -> Recorder (WithPriority a)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio (SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text)
-> (a -> SimpleDocStream Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions(Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) Recorder (WithPriority Text)
lspLogRecorder'
    (Recorder (WithPriority a), LanguageContextEnv Config -> IO ())
-> IO
     (Recorder (WithPriority a), LanguageContextEnv Config -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Recorder (WithPriority a)
lspLogRecorder Recorder (WithPriority a)
-> Recorder (WithPriority a) -> Recorder (WithPriority a)
forall a. Semigroup a => a -> a -> a
<> Recorder (WithPriority a)
logger, LanguageContextEnv Config -> IO ()
cb1)

-- | Host a server, and run a test session on it.
-- For setting custom timeout, set the environment variable 'LSP_TIMEOUT'
-- * LSP_TIMEOUT=10 cabal test
-- For more detail of the test configuration, see 'TestConfig'
runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a
runSessionWithTestConfig :: forall b a.
Pretty b =>
TestConfig b -> (String -> Session a) -> IO a
runSessionWithTestConfig TestConfig{Bool
Maybe String
Either String VirtualFileTree
Config
SessionConfig
ClientCapabilities
PluginTestDescriptor b
$sel:testDirLocation:TestConfig :: forall b. TestConfig b -> Either String VirtualFileTree
$sel:testConfigCaps:TestConfig :: forall b. TestConfig b -> ClientCapabilities
$sel:testLspConfig:TestConfig :: forall b. TestConfig b -> Config
$sel:testPluginDescriptor:TestConfig :: forall b. TestConfig b -> PluginTestDescriptor b
$sel:testClientRoot:TestConfig :: forall b. TestConfig b -> Maybe String
$sel:testServerRoot:TestConfig :: forall b. TestConfig b -> Maybe String
$sel:testShiftRoot:TestConfig :: forall b. TestConfig b -> Bool
$sel:testDisableKick:TestConfig :: forall b. TestConfig b -> Bool
$sel:testDisableDefaultPlugin:TestConfig :: forall b. TestConfig b -> Bool
$sel:testConfigSession:TestConfig :: forall b. TestConfig b -> SessionConfig
$sel:testCheckProject:TestConfig :: forall b. TestConfig b -> Bool
testDirLocation :: Either String VirtualFileTree
testShiftRoot :: Bool
testClientRoot :: Maybe String
testServerRoot :: Maybe String
testDisableKick :: Bool
testDisableDefaultPlugin :: Bool
testCheckProject :: Bool
testPluginDescriptor :: PluginTestDescriptor b
testLspConfig :: Config
testConfigSession :: SessionConfig
testConfigCaps :: ClientCapabilities
..} String -> Session a
session =
    Either String VirtualFileTree -> (String -> IO a) -> IO a
forall {b}.
Either String VirtualFileTree -> (String -> IO b) -> IO b
runSessionInVFS Either String VirtualFileTree
testDirLocation ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
root -> String -> IO a -> IO a
shiftRoot String
root (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
    let serverRoot :: String
serverRoot = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
root Maybe String
testServerRoot
    let clientRoot :: String
clientRoot = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
root Maybe String
testClientRoot

    (Recorder (WithPriority b)
recorder, LanguageContextEnv Config -> IO ()
cb1) <- Recorder (WithPriority b)
-> IO
     (Recorder (WithPriority b), LanguageContextEnv Config -> IO ())
forall a.
Pretty a =>
Recorder (WithPriority a)
-> IO
     (Recorder (WithPriority a), LanguageContextEnv Config -> IO ())
wrapClientLogger (Recorder (WithPriority b)
 -> IO
      (Recorder (WithPriority b), LanguageContextEnv Config -> IO ()))
-> IO (Recorder (WithPriority b))
-> IO
     (Recorder (WithPriority b), LanguageContextEnv Config -> IO ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Recorder (WithPriority b))
forall a. Pretty a => IO (Recorder (WithPriority a))
hlsPluginTestRecorder
    (Recorder (WithPriority Log)
recorderIde, LanguageContextEnv Config -> IO ()
cb2) <- Recorder (WithPriority Log)
-> IO
     (Recorder (WithPriority Log), LanguageContextEnv Config -> IO ())
forall a.
Pretty a =>
Recorder (WithPriority a)
-> IO
     (Recorder (WithPriority a), LanguageContextEnv Config -> IO ())
wrapClientLogger (Recorder (WithPriority Log)
 -> IO
      (Recorder (WithPriority Log), LanguageContextEnv Config -> IO ()))
-> IO (Recorder (WithPriority Log))
-> IO
     (Recorder (WithPriority Log), LanguageContextEnv Config -> IO ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Recorder (WithPriority Log))
forall a. Pretty a => IO (Recorder (WithPriority a))
hlsHelperTestRecorder
    -- This plugin just installs a handler for the `initialized` notification, which then
    -- picks up the LSP environment and feeds it to our recorders
    let lspRecorderPlugin :: IdePlugins IdeState
lspRecorderPlugin = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins [(PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
"LSPRecorderCallback" Text
"Internal plugin")
          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \IdeState
_ VFS
_ PluginId
_ MessageParams 'Method_Initialized
_ -> do
              LanguageContextEnv Config
env <- LspT Config IO (LanguageContextEnv Config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
              IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv Config -> IO ()
cb1 (LanguageContextEnv Config -> IO ())
-> (LanguageContextEnv Config -> IO ())
-> LanguageContextEnv Config
-> IO ()
forall a. Semigroup a => a -> a -> a
<> LanguageContextEnv Config -> IO ()
cb2) LanguageContextEnv Config
env
          }]

    let plugins :: IdePlugins IdeState
plugins = PluginTestDescriptor b
testPluginDescriptor Recorder (WithPriority b)
recorder IdePlugins IdeState -> IdePlugins IdeState -> IdePlugins IdeState
forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
lspRecorderPlugin
    Maybe Int
timeoutOverride <- (String -> Int) -> Maybe String -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
forall a. Read a => String -> a
read (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"LSP_TIMEOUT"
    let sconf' :: SessionConfig
sconf' = SessionConfig
testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}
        arguments :: Arguments
arguments = String
-> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
testingArgs String
serverRoot Recorder (WithPriority Log)
recorderIde IdePlugins IdeState
plugins
    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 ()
IDEMain.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)
recorderIde)
            Arguments
arguments { argsHandleIn = pure inR , argsHandleOut = pure outW }
    a
result <- 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
testConfigCaps String
clientRoot (String -> Session a
session String
root)
    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
result

    where
        shiftRoot :: String -> IO a -> IO a
shiftRoot String
shiftTarget IO a
f  =
            if Bool
testShiftRoot
                then 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
$ String -> IO ()
setCurrentDirectory String
shiftTarget IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
f
                else IO a
f
        runSessionInVFS :: Either String VirtualFileTree -> (String -> IO b) -> IO b
runSessionInVFS (Left String
testConfigRoot) String -> IO b
act = do
            String
root <- String -> IO String
makeAbsolute String
testConfigRoot
            String -> IO b
act String
root
        runSessionInVFS (Right VirtualFileTree
vfs) String -> IO b
act = VirtualFileTree -> (FileSystem -> IO b) -> IO b
forall a. VirtualFileTree -> (FileSystem -> IO a) -> IO a
runWithLockInTempDir VirtualFileTree
vfs ((FileSystem -> IO b) -> IO b) -> (FileSystem -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \FileSystem
fs -> String -> IO b
act (FileSystem -> String
fsRoot FileSystem
fs)
        testingArgs :: String
-> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
testingArgs String
prjRoot Recorder (WithPriority Log)
recorderIde IdePlugins IdeState
plugins =
            let
                arguments :: Arguments
arguments@Arguments{ IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsHlsPlugins, Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, Options
argsLspOptions :: Options
argsLspOptions :: Arguments -> Options
argsLspOptions } = Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
defaultArguments ((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)
recorderIde) String
prjRoot IdePlugins IdeState
plugins
                argsHlsPlugins' :: IdePlugins IdeState
argsHlsPlugins' = if Bool
testDisableDefaultPlugin
                                then IdePlugins IdeState
plugins
                                else IdePlugins IdeState
argsHlsPlugins
                hlsPlugins :: IdePlugins IdeState
hlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins ([PluginDescriptor IdeState] -> IdePlugins IdeState)
-> [PluginDescriptor IdeState] -> IdePlugins IdeState
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc IdePlugins IdeState
argsHlsPlugins'
                    [PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ [PluginId -> PluginDescriptor IdeState
forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command", Item [PluginDescriptor IdeState]
PluginDescriptor IdeState
Test.plugin]
                ideOptions :: Config -> Action IdeGhcSession -> IdeOptions
ideOptions Config
config Action IdeGhcSession
sessionLoader = (Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
sessionLoader){
                    optTesting = IdeTesting True
                    , optCheckProject = pure testCheckProject
                    }
            in
                Arguments
arguments
                { argsHlsPlugins = hlsPlugins
                , argsIdeOptions = ideOptions
                , argsLspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
                , argsDefaultHlsConfig = testLspConfig
                , argsProjectRoot = prjRoot
                , argsDisableKick = testDisableKick
                }

-- | Wait for the next progress begin step
waitForProgressBegin :: Session ()
waitForProgressBegin :: Session ()
waitForProgressBegin = 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 WorkDoneProgressBegin WorkDoneProgressBegin
-> Value -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism Value Value WorkDoneProgressBegin WorkDoneProgressBegin
Prism' Value WorkDoneProgressBegin
_workDoneProgressBegin Value
v-> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> Maybe ()
forall a. Maybe a
Nothing

-- | 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 (TResponseError m) (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 (TResponseError @ClientToServer (Method_CustomMethod "test")) b)
callTestPlugin :: forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) 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
  (TResponseError ('Method_CustomMethod "test"))
  (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either (TResponseError m) (MessageResult m)
_result :: Either
  (TResponseError ('Method_CustomMethod "test"))
  (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 (TResponseError ('Method_CustomMethod "test")) b
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TResponseError ('Method_CustomMethod "test")) b
 -> Session
      (Either (TResponseError ('Method_CustomMethod "test")) b))
-> Either (TResponseError ('Method_CustomMethod "test")) b
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either (TResponseError ('Method_CustomMethod "test")) Value
Either
  (TResponseError ('Method_CustomMethod "test"))
  (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 -> TResponseError ('Method_CustomMethod "test")
-> Either (TResponseError ('Method_CustomMethod "test")) b
forall a b. a -> Either a b
Left (TResponseError ('Method_CustomMethod "test")
 -> Either (TResponseError ('Method_CustomMethod "test")) b)
-> TResponseError ('Method_CustomMethod "test")
-> Either (TResponseError ('Method_CustomMethod "test")) b
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData ('Method_CustomMethod "test"))
-> TResponseError ('Method_CustomMethod "test")
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) (String -> Text
T.pack String
err) Maybe Value
Maybe (ErrorData ('Method_CustomMethod "test"))
forall a. Maybe a
Nothing
        A.Success b
a -> b -> Either (TResponseError ('Method_CustomMethod "test")) b
forall a.
a -> Either (TResponseError ('Method_CustomMethod "test")) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

waitForAction :: String -> TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) WaitForIdeRuleResult)
waitForAction :: String
-> TextDocumentIdentifier
-> Session
     (Either
        (TResponseError ('Method_CustomMethod "test"))
        WaitForIdeRuleResult)
waitForAction String
key TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} =
    TestRequest
-> Session
     (Either
        (TResponseError ('Method_CustomMethod "test"))
        WaitForIdeRuleResult)
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
callTestPlugin (String -> Uri -> TestRequest
WaitForIdeRule String
key Uri
_uri)

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

getLastBuildKeys :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])
getLastBuildKeys :: Session
  (Either (TResponseError ('Method_CustomMethod "test")) [Text])
getLastBuildKeys = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) [Text])
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) 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