Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[Migrate AsyncTests] part of 4173 Migrate ghcide tests to hls test utils #4199

Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 3 additions & 3 deletions ghcide/test/exe/AsyncTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,17 +15,17 @@ import Language.LSP.Protocol.Types hiding
mkRange)
import Language.LSP.Test
-- import Test.QuickCheck.Instances ()
import Config
import Development.IDE.Plugin.Test (TestRequest (BlockSeconds),
blockCommandId)
import Test.Tasty
import Test.Tasty.HUnit
import TestUtils

-- | Test if ghcide asynchronously handles Commands and user Requests
tests :: TestTree
tests = testGroup "async"
[
testSession "command" $ do
testWithDummyPluginEmpty "command" $ do
-- Execute a command that will block forever
let req = ExecuteCommandParams Nothing blockCommandId Nothing
void $ sendRequest SMethod_WorkspaceExecuteCommand req
Expand All @@ -38,7 +38,7 @@ tests = testGroup "async"
codeLenses <- getAndResolveCodeLenses doc
liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?
[ "foo :: a -> a" ]
, testSession "request" $ do
, testWithDummyPluginEmpty "request" $ do
-- Execute a custom request that will block for 1000 seconds
void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000
-- Load a file and check for code actions. Will only work if the request is run asynchronously
Expand Down
9 changes: 9 additions & 0 deletions ghcide/test/exe/Config.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,5 +31,14 @@ testWithDummyPlugin caseName vfs = testCase caseName . runWithDummyPlugin vfs
testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree
testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs

runWithDummyPluginEmpty :: Session a -> IO a
runWithDummyPluginEmpty = runWithDummyPlugin $ mkIdeTestFs []

testWithDummyPluginEmpty :: String -> Session () -> TestTree
testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs []

testWithDummyPluginEmpty' :: String -> (FileSystem -> Session ()) -> TestTree
testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs []

pattern R :: UInt -> UInt -> UInt -> UInt -> Range
pattern R x y x' y' = Range (Position x y) (Position x' y')
2 changes: 1 addition & 1 deletion ghcide/test/exe/DependentFileTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import Test.Tasty

tests :: TestTree
tests = testGroup "addDependentFile"
[testGroup "file-changed" [testWithDummyPlugin' "test" (mkIdeTestFs []) test]
[testGroup "file-changed" [testWithDummyPluginEmpty' "test" test]
]
where
test :: FileSystem -> Session ()
Expand Down
5 changes: 2 additions & 3 deletions ghcide/test/exe/InitializeResponseTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,7 @@ import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Test

import Config (dummyPlugin, mkIdeTestFs,
runWithDummyPlugin)
import Config
import Control.Lens ((^.))
import Development.IDE.Plugin.Test (blockCommandId)
import Test.Hls
Expand Down Expand Up @@ -88,7 +87,7 @@ tests = withResource acquire release tests where
innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"

acquire :: IO (TResponseMessage Method_Initialize)
acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse
acquire = runWithDummyPluginEmpty initializeResponse

release :: TResponseMessage Method_Initialize -> IO ()
release = mempty
Expand Down
Loading