Skip to content

Commit ed4c568

Browse files
pepeiborrapepeiborra
committed
Run server in-process for tests
This is so that we can catch SQLError for retrying
1 parent 2a05e7e commit ed4c568

File tree

3 files changed

+39
-53
lines changed

3 files changed

+39
-53
lines changed

‎ghcide/exe/Arguments.hs

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,6 @@ data Arguments = Arguments
1414
,argsShakeProfiling :: Maybe FilePath
1515
,argsOTMemoryProfiling :: Bool
1616
,argsTesting :: Bool
17-
,argsDisableKick :: Bool
1817
,argsThreads :: Int
1918
,argsVerbose :: Bool
2019
,argsCommand :: Command
@@ -36,7 +35,6 @@ arguments = Arguments
3635
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
3736
<*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
3837
<*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
39-
<*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
4038
<*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
4139
<*> switch (long "verbose" <> help "Include internal events in logging output")
4240
<*> (commandP <|> lspCommand <|> checkCommand)

‎ghcide/exe/Main.hs

Lines changed: 2 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ module Main(main) where
88
import Arguments (Arguments (..),
99
getArguments)
1010
import Control.Concurrent.Extra (newLock, withLock)
11-
import Control.Monad.Extra (unless, when, whenJust)
11+
import Control.Monad.Extra (when, whenJust)
1212
import qualified Data.Aeson.Encode.Pretty as A
1313
import Data.Default (Default (def))
1414
import Data.List.Extra (upper)
@@ -19,12 +19,9 @@ import qualified Data.Text.Lazy.IO as LT
1919
import Data.Version (showVersion)
2020
import Development.GitRev (gitHash)
2121
import Development.IDE (Logger (Logger),
22-
Priority (Info), action)
23-
import Development.IDE.Core.OfInterest (kick)
24-
import Development.IDE.Core.Rules (mainRule)
22+
Priority (Info))
2523
import qualified Development.IDE.Main as Main
2624
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
27-
import qualified Development.IDE.Plugin.Test as Test
2825
import Development.IDE.Types.Options
2926
import Development.IDE.Graph (ShakeOptions (shakeThreads))
3027
import Ide.Plugin.Config (Config (checkParents, checkProject))
@@ -78,26 +75,7 @@ main = do
7875

7976
Main.defaultMain def
8077
{Main.argCommand = argsCommand
81-
8278
,Main.argsLogger = pure logger
83-
84-
,Main.argsRules = do
85-
-- install the main and ghcide-plugin rules
86-
mainRule
87-
-- install the kick action, which triggers a typecheck on every
88-
-- Shake database restart, i.e. on every user edit.
89-
unless argsDisableKick $
90-
action kick
91-
92-
,Main.argsHlsPlugins =
93-
pluginDescToIdePlugins $
94-
GhcIde.descriptors
95-
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
96-
97-
,Main.argsGhcidePlugin = if argsTesting
98-
then Test.plugin
99-
else mempty
100-
10179
,Main.argsIdeOptions = \config sessionLoader ->
10280
let defOptions = defaultIdeOptions sessionLoader
10381
in defOptions

‎ghcide/test/exe/Main.hs

Lines changed: 37 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,8 @@ import Development.IDE.Test (Cursor,
5555
import Development.IDE.Test.Runfiles
5656
import qualified Development.IDE.Types.Diagnostics as Diagnostics
5757
import Development.IDE.Types.Location
58-
import Development.Shake (getDirectoryFilesIO)
58+
import Development.IDE.Types.Options
59+
import Development.Shake (getDirectoryFilesIO, shakeThreads)
5960
import qualified Experiments as Bench
6061
import Ide.Plugin.Config
6162
import Language.LSP.Test
@@ -100,7 +101,9 @@ import Ide.Types
100101
import Data.String (IsString(fromString))
101102
import qualified Language.LSP.Types as LSP
102103
import Data.IORef.Extra (atomicModifyIORef_)
104+
import Development.IDE.Core.Rules (mainRule)
103105
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
106+
import qualified Development.IDE.Plugin.Test as Test
104107
import Text.Regex.TDFA ((=~))
105108

106109
waitForProgressBegin :: Session ()
@@ -706,7 +709,8 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r
706709
expectNoMoreDiagnostics 0.5
707710
where
708711
-- similar to run except it disables kick
709-
runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s
712+
runTestNoKick s = withTempDir $ \dir -> runInDir' argsNoKick dir "." "." s
713+
argsNoKick = def { IDE.argsRules = mainRule }
710714

711715
typeCheck doc = do
712716
Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
@@ -4940,7 +4944,7 @@ rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
49404944
where
49414945
-- similar to run' except we can configure where to start ghcide and session
49424946
runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()
4943-
runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)
4947+
runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' def dir dir1 dir2 (s dir)
49444948

49454949
-- | Test if ghcide asynchronously handles Commands and user Requests
49464950
asyncTests :: TestTree
@@ -5224,15 +5228,14 @@ run' :: (FilePath -> Session a) -> IO a
52245228
run' s = withTempDir $ \dir -> runInDir dir (s dir)
52255229

52265230
runInDir :: FilePath -> Session a -> IO a
5227-
runInDir dir = runInDir' dir "." "." []
5231+
runInDir dir = runInDir' def dir "." "."
52285232

52295233
withLongTimeout :: IO a -> IO a
52305234
withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")
52315235

52325236
-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.
5233-
runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a
5234-
runInDir' dir startExeIn startSessionIn extraOptions s = do
5235-
ghcideExe <- locateGhcideExecutable
5237+
runInDir' :: IDE.Arguments -> FilePath -> FilePath -> FilePath -> Session a -> IO a
5238+
runInDir' args dir startExeIn startSessionIn s = do
52365239
let startDir = dir </> startExeIn
52375240
let projDir = dir </> startSessionIn
52385241

@@ -5241,19 +5244,13 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
52415244
-- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
52425245
-- since the package import test creates "Data/List.hs", which otherwise has no physical home
52435246
createDirectoryIfMissing True $ projDir ++ "/Data"
5244-
5245-
shakeProfiling <- getEnv "SHAKE_PROFILING"
5246-
let cmd = unwords $
5247-
[ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir
5248-
] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]
5249-
] ++ extraOptions
52505247
-- HIE calls getXgdDirectory which assumes that HOME is set.
52515248
-- Only sets HOME if it wasn't already set.
52525249
setEnv "HOME" "/homeless-shelter" False
5253-
conf <- getConfigFromEnv
5254-
runSessionWithConfig conf cmd lspTestCaps projDir s
52555250

5256-
getConfigFromEnv :: IO SessionConfig
5251+
testIde dir args s
5252+
5253+
getConfigFromEnv ::IO SessionConfig
52575254
getConfigFromEnv = do
52585255
logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"
52595256
timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"
@@ -5349,37 +5346,50 @@ unitTests = do
53495346
| i <- [(1::Int)..20]
53505347
] ++ Ghcide.descriptors
53515348

5352-
testIde def{IDE.argsHlsPlugins = plugins} $ do
5349+
testIde "." def{IDE.argsHlsPlugins = plugins} $ do
53535350
_ <- createDoc "haskell" "A.hs" "module A where"
53545351
waitForProgressDone
53555352
actualOrder <- liftIO $ readIORef orderRef
53565353

53575354
liftIO $ actualOrder @?= reverse [(1::Int)..20]
53585355
]
53595356

5360-
testIde :: IDE.Arguments -> Session () -> IO ()
5361-
testIde arguments session = do
5357+
testIde :: FilePath -> IDE.Arguments -> Session a -> IO a
5358+
testIde rootDir arguments session = do
53625359
config <- getConfigFromEnv
5360+
shakeProfiling <- getEnv "SHAKE_PROFILING"
53635361
(hInRead, hInWrite) <- createPipe
53645362
(hOutRead, hOutWrite) <- createPipe
53655363
server <- async $ IDE.defaultMain arguments
5366-
{ IDE.argsHandleIn = pure hInRead
5367-
, IDE.argsHandleOut = pure hOutWrite
5368-
, IDE.argsIdeOptions = \config sessionLoader ->
5369-
let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True}
5370-
in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}
5371-
}
5364+
-- TODO install a logger that logs to the LSP stream, otherwise it's hard to debug test failures
5365+
{ IDE.argsHandleIn = pure hInRead
5366+
, IDE.argsHandleOut = pure hOutWrite
5367+
, IDE.argsHlsPlugins =
5368+
pluginDescToIdePlugins $
5369+
Ghcide.descriptors
5370+
++ [Test.blockCommandDescriptor "block-command" ]
5371+
, IDE.argsGhcidePlugin = Test.plugin
5372+
, IDE.argsIdeOptions = \config sessionLoader ->
5373+
let ideOptions = (IDE.argsIdeOptions def config sessionLoader)
5374+
{optTesting = IdeTesting True
5375+
,optShakeProfiling = shakeProfiling
5376+
}
5377+
in ideOptions
5378+
{ optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}
5379+
}
53725380

5373-
runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session
5381+
res <- runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session
53745382

5375-
hClose inw
5383+
hClose hInWrite
53765384
timeout 3 (wait server) >>= \case
53775385
Just () -> pure ()
53785386
Nothing -> do
53795387
putStrLn "Server does not exit in 3s, canceling the async task..."
53805388
(t, _) <- duration $ cancel server
53815389
putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"
53825390

5391+
return res
5392+
53835393
positionMappingTests :: TestTree
53845394
positionMappingTests =
53855395
testGroup "position mapping"

0 commit comments

Comments
 (0)