{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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,
runSessionWithServer,
runSessionWithServerAndCaps,
runSessionWithServerFormatter,
runSessionWithCabalServerFormatter,
runSessionWithServer',
PluginDescriptor,
IdeState,
waitForProgressDone,
waitForAllProgressDone,
waitForBuildQueue,
waitForTypecheck,
waitForAction,
sendConfigurationChanged,
getLastBuildKeys,
waitForKickDone,
waitForKickStart,
PluginTestDescriptor,
pluginTestRecorder,
mkPluginTestDescriptor,
mkPluginTestDescriptor',
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
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = TestTree -> IO ()
defaultMainWithRerun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int -> NumThreads
NumThreads Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Integer -> Timeout
mkTimeout Integer
600000000)
gitDiff :: FilePath -> FilePath -> [String]
gitDiff :: FilePath -> FilePath -> [FilePath]
gitDiff FilePath
fRef FilePath
fNew = [FilePath
"git", FilePath
"-c", FilePath
"core.fileMode=false", FilePath
"diff", FilePath
"--no-index", FilePath
"--text", FilePath
"--exit-code", FilePath
fRef, FilePath
fNew]
goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff :: FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
name = FilePath
-> (FilePath -> FilePath -> [FilePath])
-> FilePath
-> IO ByteString
-> TestTree
goldenVsStringDiff FilePath
name FilePath -> FilePath -> [FilePath]
gitDiff
goldenWithHaskellDoc
:: Pretty b
=> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc = forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"haskell"
goldenWithHaskellAndCaps
:: Pretty b
=> ClientCapabilities
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCaps :: forall b.
Pretty b =>
ClientCapabilities
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCaps ClientCapabilities
clientCaps PluginTestDescriptor b
plugin FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b
-> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps PluginTestDescriptor b
plugin ClientCapabilities
clientCaps FilePath
testDataDir
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
goldenWithCabalDoc
:: Pretty b
=> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDoc :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDoc = forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"cabal"
goldenWithDoc
:: Pretty b
=> T.Text
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc :: forall b.
Pretty b =>
Text
-> PluginTestDescriptor b
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
fileType PluginTestDescriptor b
plugin FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer PluginTestDescriptor b
plugin FilePath
testDataDir
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
fileType
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
type PluginTestDescriptor b = Recorder (WithPriority b) -> IdePlugins IdeState
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]
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]
pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder :: forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder = do
(Recorder (WithPriority a)
recorder, WithPriority (Doc Any) -> IO ()
_) <- forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [FilePath
"HLS_TEST_PLUGIN_LOG_STDERR", FilePath
"HLS_TEST_LOG_STDERR"]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Recorder (WithPriority a)
recorder
initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder :: forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [FilePath]
envVars = do
Recorder (WithPriority (Doc ann))
docWithPriorityRecorder <- forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder forall a. Maybe a
Nothing
[FilePath]
definedEnvVars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
envVars (\FilePath
var -> forall a. a -> Maybe a -> a
fromMaybe FilePath
"0" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
var)
let logStdErr :: Bool
logStdErr = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/= FilePath
"0") [FilePath]
definedEnvVars
docWithFilteredPriorityRecorder :: Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder =
if Bool
logStdErr then forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter (\WithPriority{ Priority
priority :: Priority
priority :: forall a. WithPriority a -> Priority
priority } -> Priority
priority forall a. Ord a => a -> a -> Bool
>= Priority
Debug) Recorder (WithPriority (Doc ann))
docWithPriorityRecorder
else forall a. Monoid a => a
mempty
Recorder {forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_} = Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a ann. Pretty a => a -> Doc ann
pretty Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder, forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_)
runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer :: forall b a.
Pretty b =>
PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer PluginTestDescriptor b
plugin FilePath
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) forall a. Default a => a
def forall a. Default a => a
def ClientCapabilities
fullCaps FilePath
fp Session a
act
runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps PluginTestDescriptor b
plugin ClientCapabilities
caps FilePath
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) forall a. Default a => a
def forall a. Default a => a
def ClientCapabilities
caps FilePath
fp Session a
act
runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
(PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder)
forall a. Default a => a
def
{ formattingProvider :: Text
formattingProvider = FilePath -> Text
T.pack FilePath
formatter
, plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
}
forall a. Default a => a
def
ClientCapabilities
fullCaps
FilePath
fp
Session a
act
goldenWithHaskellDocFormatter
:: Pretty b
=> PluginTestDescriptor b
-> String
-> PluginConfig
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> PluginConfig
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
testDataDir
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
goldenWithCabalDocFormatter
:: Pretty b
=> PluginTestDescriptor b
-> String
-> PluginConfig
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter :: forall b.
Pretty b =>
PluginTestDescriptor b
-> FilePath
-> PluginConfig
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
testDataDir
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"cabal"
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter :: forall b a.
Pretty b =>
PluginTestDescriptor b
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithCabalServerFormatter PluginTestDescriptor b
plugin FilePath
formatter PluginConfig
conf FilePath
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
(PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder)
forall a. Default a => a
def
{ cabalFormattingProvider :: Text
cabalFormattingProvider = FilePath -> Text
T.pack FilePath
formatter
, plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
}
forall a. Default a => a
def
ClientCapabilities
fullCaps
FilePath
fp Session a
act
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory :: forall a. IO a -> IO a
keepCurrentDirectory = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
getCurrentDirectory FilePath -> IO ()
setCurrentDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# NOINLINE lock #-}
lock :: Lock
lock :: Lock
lock = forall a. IO a -> a
unsafePerformIO IO Lock
newLock
runSessionWithServer' ::
IdePlugins IdeState ->
Config ->
SessionConfig ->
ClientCapabilities ->
FilePath ->
Session a ->
IO a
runSessionWithServer' :: forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' IdePlugins IdeState
plugins Config
conf SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s = forall a. Lock -> IO a -> IO a
withLock Lock
lock forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
keepCurrentDirectory forall a b. (a -> b) -> a -> b
$ do
(Handle
inR, Handle
inW) <- IO (Handle, Handle)
createPipe
(Handle
outR, Handle
outW) <- IO (Handle, Handle)
createPipe
(Recorder (WithPriority Log)
recorder, WithPriority (Doc Any) -> IO ()
logger_) <- forall a ann.
Pretty a =>
[FilePath]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder
[FilePath
"LSP_TEST_LOG_STDERR", FilePath
"HLS_TEST_SERVER_LOG_STDERR", FilePath
"HLS_TEST_LOG_STDERR"]
let
logger :: Logger
logger = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> WithPriority (Doc Any) -> IO ()
logger_ (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack (forall a ann. Pretty a => a -> Doc ann
pretty Text
m))
hlsPlugins :: IdePlugins IdeState
hlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command"] forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
plugins
arguments :: Arguments
arguments@Arguments{ Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, IO Logger
argsLogger :: Arguments -> IO Logger
argsLogger :: IO Logger
argsLogger } =
Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
testing (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Logger
logger IdePlugins IdeState
hlsPlugins
ideOptions :: Config -> Action IdeGhcSession -> IdeOptions
ideOptions Config
config Action IdeGhcSession
ghcSession =
let defIdeOptions :: IdeOptions
defIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
ghcSession
in IdeOptions
defIdeOptions
{ optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True
, optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
}
Async ()
server <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$
Recorder (WithPriority Log) -> Arguments -> IO ()
Ghcide.defaultMain (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder)
Arguments
arguments
{ argsHandleIn :: IO Handle
argsHandleIn = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
inR
, argsHandleOut :: IO Handle
argsHandleOut = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
outW
, argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
conf
, argsLogger :: IO Logger
argsLogger = IO Logger
argsLogger
, argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
ideOptions
}
a
x <- forall a.
Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithHandles Handle
inW Handle
outR SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s
Handle -> IO ()
hClose Handle
inW
forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
3 (forall a. Async a -> IO a
wait Async ()
server) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe ()
Nothing -> do
FilePath -> IO ()
putStrLn FilePath
"Server does not exit in 3s, canceling the async task..."
(Seconds
t, ()
_) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
cancel Async ()
server
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Finishing canceling (took " forall a. Semigroup a => a -> a -> a
<> Seconds -> FilePath
showDuration Seconds
t forall a. Semigroup a => a -> a -> a
<> FilePath
"s)"
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
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
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
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
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 FilePath
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) (FilePath -> Text
T.pack FilePath
err) forall a. Maybe a
Nothing
A.Success b
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction :: FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin (FilePath -> Uri -> TestRequest
WaitForIdeRule FilePath
key Uri
_uri)
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck TextDocumentIdentifier
tid = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WaitForIdeRuleResult -> Bool
ideResultSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
"typecheck" TextDocumentIdentifier
tid
getLastBuildKeys :: Session (Either ResponseError [T.Text])
getLastBuildKeys :: Session (Either ResponseError [Text])
getLastBuildKeys = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
GetBuildKeysBuilt
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged Value
config =
forall (m :: Method 'ClientToServer 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration (Value -> DidChangeConfigurationParams
DidChangeConfigurationParams Value
config)
waitForKickDone :: Session ()
waitForKickDone :: Session ()
waitForKickDone = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickDone
waitForKickStart :: Session ()
waitForKickStart :: Session ()
waitForKickStart = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickStart
nonTrivialKickDone :: Session ()
nonTrivialKickDone :: Session ()
nonTrivialKickDone = forall (k :: Symbol).
KnownSymbol k =>
Proxy k -> Session [FilePath]
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 [FilePath]
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 [FilePath]
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 [FilePath]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
x
Result [FilePath]
other -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse kick/done details: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Result [FilePath]
other