/
Hls.hs
251 lines (231 loc) · 9.52 KB
/
Hls.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Hls
( module Test.Tasty.HUnit,
module Test.Tasty,
module Test.Tasty.ExpectedFailure,
module Test.Hls.Util,
module Language.LSP.Types,
module Language.LSP.Test,
module Control.Monad.IO.Class,
module Control.Applicative.Combinators,
defaultTestRunner,
goldenGitDiff,
goldenWithHaskellDoc,
goldenWithHaskellDocFormatter,
def,
runSessionWithServer,
runSessionWithServerFormatter,
runSessionWithServer',
waitForProgressDone,
waitForAllProgressDone,
PluginDescriptor,
IdeState,
waitForBuildQueue,
waitForTypecheck,
waitForAction,
sendConfigurationChanged,
getLastBuildKeys)
where
import Control.Applicative.Combinators
import Control.Concurrent.Async (async, cancel, wait)
import Control.Concurrent.Extra
import Control.Exception.Base
import Control.Monad (unless, void)
import Control.Monad.IO.Class
import Data.Aeson (Value (Null), toJSON)
import qualified Data.Aeson as A
import Data.ByteString.Lazy (ByteString)
import Data.Default (def)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Development.IDE (IdeState, noLogging)
import Development.IDE.Graph (ShakeOptions (shakeThreads))
import Development.IDE.Main
import qualified Development.IDE.Main as Ghcide
import Development.IDE.Plugin.Test (TestRequest (GetLastBuildKeys, WaitForIdeRule, WaitForShakeQueue),
WaitForIdeRuleResult (ideResultSuccess))
import Development.IDE.Types.Options
import GHC.IO.Handle
import Ide.Plugin.Config (Config, formattingProvider)
import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins)
import Ide.Types
import Language.LSP.Test
import Language.LSP.Types hiding
(SemanticTokenAbsolute (length, line),
SemanticTokenRelative (length),
SemanticTokensEdit (_start))
import Language.LSP.Types.Capabilities (ClientCapabilities)
import 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
-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000)
gitDiff :: FilePath -> FilePath -> [String]
gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]
goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff name = goldenVsStringDiff name gitDiff
goldenWithHaskellDoc
:: PluginDescriptor IdeState
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc plugin title testDataDir path desc ext act =
goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
$ runSessionWithServer plugin testDataDir
$ TL.encodeUtf8 . TL.fromStrict
<$> do
doc <- openDoc (path <.> ext) "haskell"
void waitForBuildQueue
act doc
documentContents doc
goldenWithHaskellDocFormatter
:: PluginDescriptor IdeState
-> String
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext act =
goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
$ runSessionWithServerFormatter plugin formatter testDataDir
$ TL.encodeUtf8 . TL.fromStrict
<$> do
doc <- openDoc (path <.> ext) "haskell"
void waitForBuildQueue
act doc
documentContents doc
runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps
runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a
runSessionWithServerFormatter plugin formatter =
runSessionWithServer'
[plugin]
def {formattingProvider = T.pack formatter}
def
fullCaps
-- | Restore cwd after running an action
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const
{-# NOINLINE lock #-}
-- | Never run in parallel
lock :: Lock
lock = unsafePerformIO 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
[PluginDescriptor IdeState] ->
-- | lsp config for the server
Config ->
-- | config for the test session
SessionConfig ->
ClientCapabilities ->
FilePath ->
Session a ->
IO a
runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do
(inR, inW) <- createPipe
(outR, outW) <- createPipe
let logger = do
logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR"
if logStdErr == "0"
then return noLogging
else argsLogger testing
server <-
async $
Ghcide.defaultMain
testing
{ argsHandleIn = pure inR,
argsHandleOut = pure outW,
argsDefaultHlsConfig = conf,
argsLogger = logger,
argsIdeOptions = \config sessionLoader ->
let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True}
in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}},
argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing)
}
x <- runSessionWithHandles inW outR sconf caps root s
hClose inW
timeout 3 (wait server) >>= \case
Just () -> pure ()
Nothing -> do
putStrLn "Server does not exit in 3s, canceling the async task..."
(t, _) <- duration $ cancel server
putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"
pure x
-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForProgressDone :: Session ()
waitForProgressDone = loop
where
loop = do
() <- skipManyTill anyMessage $ satisfyMaybe $ \case
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()
_ -> Nothing
done <- null <$> getIncompleteProgressSessions
unless done loop
-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForAllProgressDone :: Session ()
waitForAllProgressDone = loop
where
loop = do
~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()
_ -> Nothing
done <- null <$> getIncompleteProgressSessions
unless done loop
-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
let m = SCustomMethod "test"
waitId <- sendRequest m (toJSON WaitForShakeQueue)
(td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
case resp of
ResponseMessage{_result=Right Null} -> return td
-- assume a ghcide binary lacking the WaitForShakeQueue method
_ -> return 0
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
callTestPlugin cmd = do
let cm = SCustomMethod "test"
waitId <- sendRequest cm (A.toJSON cmd)
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
return $ do
e <- _result
case A.fromJSON e of
A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing
A.Success a -> pure a
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction key TextDocumentIdentifier{_uri} =
callTestPlugin (WaitForIdeRule key _uri)
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid
getLastBuildKeys :: Session (Either ResponseError [T.Text])
getLastBuildKeys = callTestPlugin GetLastBuildKeys
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged config =
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)