{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE OverloadedLists          #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PolyKinds                #-}
{-# LANGUAGE RankNTypes               #-}
{-# 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,
    goldenWithHaskellAndCaps,
    goldenWithCabalDoc,
    goldenWithHaskellDocFormatter,
    goldenWithCabalDocFormatter,
    def,
    -- * Running HLS for integration tests
    runSessionWithServer,
    runSessionWithServerAndCaps,
    runSessionWithServer',
    -- * 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 (Debug),
                                                     Recorder (Recorder, logger_),
                                                     WithPriority (WithPriority, priority),
                                                     cfilter, cmapWithPrio,
                                                     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.Unsafe                   (unsafePerformIO)
import           System.Process.Extra               (createPipe)
import           System.Time.Extra
import           Test.Hls.Util
import           Test.Tasty                         hiding (Timeout)
import           Test.Tasty.ExpectedFailure
import           Test.Tasty.Golden
import           Test.Tasty.HUnit
import           Test.Tasty.Ingredients.Rerun
import           Test.Tasty.Runners                 (NumThreads (..))

newtype Log = LogIDEMain IDEMain.Log

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

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

gitDiff :: FilePath -> FilePath -> [String]
gitDiff :: String -> String -> [String]
gitDiff String
fRef String
fNew = [String
"git", String
"-c", String
"core.fileMode=false", String
"diff", String
"--no-index", String
"--text", String
"--exit-code", String
fRef, 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 = forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc 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)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServerAndCaps Config
config PluginTestDescriptor b
plugin ClientCapabilities
clientCaps String
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

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 = 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)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config PluginTestDescriptor b
plugin String
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
fileType
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

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

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

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

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

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

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

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

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

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

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

runSessionWithServer :: Pretty b => 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 <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) Config
config 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 <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
  forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) Config
config forall a. Default a => a
def ClientCapabilities
caps String
fp 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 :: Text
formattingProvider = String -> Text
T.pack String
formatter , plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
formatter) PluginConfig
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)
  forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config' PluginTestDescriptor b
plugin String
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"haskell"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

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

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

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

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

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

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

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

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

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

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

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

-- | Wait for the next progress end step
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess  SMethod m
SMethod_Progress  (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | forall s t a b. APrism s t a b -> s -> Bool
is Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v-> forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForAllProgressDone :: Session ()
waitForAllProgressDone :: Session ()
waitForAllProgressDone = Session ()
loop
  where
    loop :: Session ()
loop = do
      ~() <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess  SMethod m
SMethod_Progress  (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | forall s t a b. APrism s t a b -> s -> Bool
is Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v -> forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> forall a. Maybe a
Nothing
      Bool
done <- forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done Session ()
loop

-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
    let m :: SMethod ('Method_CustomMethod "test")
m = forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m (forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, TResponseMessage ('Method_CustomMethod "test")
resp) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId 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} -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        TResponseMessage ('Method_CustomMethod "test")
_                                    -> 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 = forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    TResponseMessage{Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result :: Either ResponseError (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result} <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
waitId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result
      case forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
        A.Error String
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) (String -> Text
T.pack String
err) forall a. Maybe a
Nothing
        A.Success b
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction :: String
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction String
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
    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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WaitForIdeRuleResult -> Bool
ideResultSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction String
"typecheck" TextDocumentIdentifier
tid

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

hlsConfigToClientConfig :: Config -> A.Object
hlsConfigToClientConfig :: Config -> Object
hlsConfigToClientConfig Config
config = [(Key
"haskell", 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 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!
  forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
configurationRequest)

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

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

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

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

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