@@ -1,7 +1,6 @@
11-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4−{-# LANGUAGE AllowAmbiguousTypes #-}
54{-# LANGUAGE DuplicateRecordFields #-}
65{-# LANGUAGE PatternSynonyms #-}
76{-# LANGUAGE CPP #-}
@@ -10,32 +9,29 @@
109module Main (main) where
1110
1211import Control.Applicative.Combinators
13−import Control.Exception (bracket, catch)
14−import qualified Control.Lens as Lens
12+import Control.Exception (catch)
1513import Control.Monad
1614import Control.Monad.IO.Class (liftIO)
17−import Data.Aeson (FromJSON, Value)
15+import Data.Aeson (Value)
16+import Data.Char (toLower)
1817import Data.Foldable
19−import Data.List.Extra
18+import Data.List
2019import Data.Rope.UTF16 (Rope)
2120import qualified Data.Rope.UTF16 as Rope
2221import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
2322import Development.IDE.GHC.Util
2423import qualified Data.Text as T
25−import Data.Typeable
2624import Development.IDE.Spans.Common
2725import Development.IDE.Test
2826import Development.IDE.Test.Runfiles
2927import Development.IDE.Types.Location
30−import Development.Shake (getDirectoryFilesIO)
31−import Language.Haskell.LSP.Test
28+import qualified Language.Haskell.LSP.Test as LSPTest
29+import Language.Haskell.LSP.Test hiding (openDoc')
3230import Language.Haskell.LSP.Messages
3331import Language.Haskell.LSP.Types
3432import Language.Haskell.LSP.Types.Capabilities
35−import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
3633import Language.Haskell.LSP.VFS (applyChange)
37−import Network.URI
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
34+import System.Environment.Blank (setEnv)
3935import System.FilePath
4036import System.IO.Extra
4137import System.Directory
@@ -49,35 +45,31 @@ import Test.Tasty.QuickCheck
4945import Data.Maybe
5046
5147main :: IO ()
52−main = do
53− -- We mess with env vars so run single-threaded.
54− setEnv "TASTY_NUM_THREADS" "1" True
55− defaultMainWithRerun $ testGroup "HIE"
56− [ testSession "open close" $ do
57− doc <- createDoc "Testing.hs" "haskell" ""
58− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
59− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
60− closeDoc doc
61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
62− , initializeResponseTests
63− , completionTests
64− , cppTests
65− , diagnosticTests
66− , codeActionTests
67− , codeLensesTests
68− , outlineTests
69− , findDefinitionAndHoverTests
70− , pluginTests
71− , preprocessorTests
72− , thTests
73− , safeTests
74− , unitTests
75− , haddockTests
76− , positionMappingTests
77− , watchedFilesTests
78− , cradleTests
79− , dependentFileTest
80− ]
48+main = defaultMainWithRerun $ testGroup "HIE"
49+ [ testSession "open close" $ do
50+ doc <- openDoc' "Testing.hs" "haskell" ""
51+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
52+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
53+ closeDoc doc
54+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
55+ , initializeResponseTests
56+ , completionTests
57+ , cppTests
58+ , diagnosticTests
59+ , codeActionTests
60+ , codeLensesTests
61+ , outlineTests
62+ , findDefinitionAndHoverTests
63+ , pluginTests
64+ , preprocessorTests
65+ , thTests
66+ , safeTests
67+ , unitTests
68+ , haddockTests
69+ , positionMappingTests
70+ , watchedFilesTests
71+ , cradleTests
72+ ]
8173
8274initializeResponseTests :: TestTree
8375initializeResponseTests = withResource acquire release tests where
@@ -112,7 +104,7 @@ initializeResponseTests = withResource acquire release tests where
112104 , chk "NO doc link" _documentLinkProvider Nothing
113105 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114106 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
107+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116108 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
117109 , chk "NO experimental" _experimental Nothing
118110 ] where
@@ -128,17 +120,8 @@ initializeResponseTests = withResource acquire release tests where
128120 chk title getActual expected =
129121 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
130122
131− che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132− che title getActual _expected = testCase title doTest
133− where
134− doTest = do
135− ir <- getInitializeResponse
136− let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137− True @=? T.isSuffixOf "typesignature.add" command
138−
139−
140123 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
124+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
142125 innerCaps _ = error "this test only expects inner capabilities"
143126
144127 acquire :: IO InitializeResponse
@@ -152,7 +135,7 @@ diagnosticTests :: TestTree
152135diagnosticTests = testGroup "diagnostics"
153136 [ testSessionWait "fix syntax error" $ do
154137 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
138+ doc <- openDoc' "Testing.hs" "haskell" content
156139 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
157140 let change = TextDocumentContentChangeEvent
158141 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -163,7 +146,7 @@ diagnosticTests = testGroup "diagnostics"
163146 expectDiagnostics [("Testing.hs", [])]
164147 , testSessionWait "introduce syntax error" $ do
165148 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
149+ doc <- openDoc' "Testing.hs" "haskell" content
167150 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
168151 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
169152 let change = TextDocumentContentChangeEvent
@@ -181,7 +164,7 @@ diagnosticTests = testGroup "diagnostics"
181164 , "bar :: Int -> Int -> Int"
182165 , "bar a b = cd + b"
183166 ]
184− _ <- createDoc "Testing.hs" "haskell" content
167+ _ <- openDoc' "Testing.hs" "haskell" content
185168 expectDiagnostics
186169 [ ( "Testing.hs"
187170 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -195,7 +178,7 @@ diagnosticTests = testGroup "diagnostics"
195178 , "foo :: Int -> String -> Int"
196179 , "foo a b = a + b"
197180 ]
198− _ <- createDoc "Testing.hs" "haskell" content
181+ _ <- openDoc' "Testing.hs" "haskell" content
199182 expectDiagnostics
200183 [ ( "Testing.hs"
201184 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -207,7 +190,7 @@ diagnosticTests = testGroup "diagnostics"
207190 , "foo :: Int -> String"
208191 , "foo a = _ a"
209192 ]
210− _ <- createDoc "Testing.hs" "haskell" content
193+ _ <- openDoc' "Testing.hs" "haskell" content
211194 expectDiagnostics
212195 [ ( "Testing.hs"
213196 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -229,23 +212,24 @@ diagnosticTests = testGroup "diagnostics"
229212 [ ("A.hs", [(DsError, (2,4), aMessage)])
230213 , ("B.hs", [(DsError, (3,4), bMessage)])]
231214 deferralTest title binding msg = testSessionWait title $ do
232− _ <- createDoc "A.hs" "haskell" $ sourceA binding
233− _ <- createDoc "B.hs" "haskell" sourceB
215+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding
216+ _ <- openDoc' "B.hs" "haskell" sourceB
234217 expectDiagnostics $ expectedDs msg
235218 in
236219 [ deferralTest "type error" "True" "Couldn't match expected type"
237220 , deferralTest "typed hole" "_" "Found hole"
238221 , deferralTest "out of scope var" "unbound" "Variable not in scope"
222+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"
239223 ]
240224
241225 , testSessionWait "remove required module" $ do
242226 let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
227+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
244228 let contentB = T.unlines
245229 [ "module ModuleB where"
246230 , "import ModuleA"
247231 ]
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
232+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
249233 let change = TextDocumentContentChangeEvent
250234 { _range = Just (Range (Position 0 0) (Position 0 20))
251235 , _rangeLength = Nothing
@@ -258,20 +242,20 @@ diagnosticTests = testGroup "diagnostics"
258242 [ "module ModuleB where"
259243 , "import ModuleA"
260244 ]
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
245+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
262246 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263247 let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
248+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
265249 expectDiagnostics [("ModuleB.hs", [])]
266250 , testSessionWait "add missing module (non workspace)" $ do
267251 let contentB = T.unlines
268252 [ "module ModuleB where"
269253 , "import ModuleA"
270254 ]
271− _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
255+ _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
272256 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273257 let contentA = T.unlines [ "module ModuleA where" ]
274− _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
258+ _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
275259 expectDiagnostics [("/tmp/ModuleB.hs", [])]
276260 , testSessionWait "cyclic module dependency" $ do
277261 let contentA = T.unlines
@@ -282,8 +266,8 @@ diagnosticTests = testGroup "diagnostics"
282266 [ "module ModuleB where"
283267 , "import ModuleA"
284268 ]
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
269+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
270+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
287271 expectDiagnostics
288272 [ ( "ModuleA.hs"
289273 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -304,9 +288,9 @@ diagnosticTests = testGroup "diagnostics"
304288 let contentBboot = T.unlines
305289 [ "module ModuleB where"
306290 ]
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
291+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
292+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
293+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
310294 expectDiagnostics []
311295 , testSessionWait "correct reference used with hs-boot" $ do
312296 let contentB = T.unlines
@@ -328,10 +312,10 @@ diagnosticTests = testGroup "diagnostics"
328312 -- resolved to the hs-boot file
329313 , "y = x"
330314 ]
331− _ <- createDoc "ModuleB.hs" "haskell" contentB
332− _ <- createDoc "ModuleA.hs" "haskell" contentA
333− _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
334− _ <- createDoc "ModuleC.hs" "haskell" contentC
315+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
316+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
317+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
318+ _ <- openDoc' "ModuleC.hs" "haskell" contentC
335319 expectDiagnostics []
336320 , testSessionWait "redundant import" $ do
337321 let contentA = T.unlines ["module ModuleA where"]
@@ -340,8 +324,8 @@ diagnosticTests = testGroup "diagnostics"
340324 , "module ModuleB where"
341325 , "import ModuleA"
342326 ]
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
327+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
328+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
345329 expectDiagnostics
346330 [ ( "ModuleB.hs"
347331 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -363,8 +347,8 @@ diagnosticTests = testGroup "diagnostics"
363347 , "wrong1 = ThisList.map"
364348 , "wrong2 = BaseList.x"
365349 ]
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
350+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
351+ _ <- openDoc' "Main.hs" "haskell" mainContent
368352 expectDiagnostics
369353 [ ( "Main.hs"
370354 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -379,7 +363,7 @@ diagnosticTests = testGroup "diagnostics"
379363 , "foo :: Ord a => a -> Int"
380364 , "foo a = 1"
381365 ]
382− _ <- createDoc "Foo.hs" "haskell" fooContent
366+ _ <- openDoc' "Foo.hs" "haskell" fooContent
383367 expectDiagnostics
384368 [ ( "Foo.hs"
385369 -- The test is to make sure that warnings contain unqualified names
@@ -404,18 +388,18 @@ diagnosticTests = testGroup "diagnostics"
404388 Just pathB <- pure $ uriToFilePath uriB
405389 uriB <- pure $
406390 let (drive, suffix) = splitDrive pathB
407− in filePathToUri (joinDrive (lower drive) suffix)
391+ in filePathToUri (joinDrive (map toLower drive ) suffix)
408392 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409393 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410394 uriA <- getDocUri "A/A.hs"
411395 Just pathA <- pure $ uriToFilePath uriA
412396 uriA <- pure $
413397 let (drive, suffix) = splitDrive pathA
414− in filePathToUri (joinDrive (lower drive) suffix)
398+ in filePathToUri (joinDrive (map toLower drive ) suffix)
415399 let itemA = TextDocumentItem uriA "haskell" 0 aContent
416400 let a = TextDocumentIdentifier uriA
417401 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418− diagsNot <- skipManyTill anyMessage diagnostic
402+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
419403 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420404 -- Check that if we put a lower-case drive in for A.A
421405 -- the diagnostics for A.B will also be lower-case.
@@ -424,38 +408,6 @@ diagnosticTests = testGroup "diagnostics"
424408 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425409 assertFailure ("Expected redundant import but got " <> T.unpack msg)
426410 closeDoc a
427− , testSessionWait "haddock parse error" $ do
428− let fooContent = T.unlines
429− [ "module Foo where"
430− , "foo :: Int"
431− , "foo = 1 {-|-}"
432− ]
433− _ <- createDoc "Foo.hs" "haskell" fooContent
434− expectDiagnostics
435− [ ( "Foo.hs"
436− , [(DsError, (2, 8), "Parse error on input")
437− ]
438− )
439− ]
440− , testSessionWait "strip file path" $ do
441− let
442− name = "Testing"
443− content = T.unlines
444− [ "module " <> name <> " where"
445− , "value :: Maybe ()"
446− , "value = [()]"
447− ]
448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449− notification <- skipManyTill anyMessage diagnostic
450− let
451− offenders =
452− Lsp.params .
453− Lsp.diagnostics .
454− Lens.folded .
455− Lsp.message .
456− Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457− failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458− Lens.mapMOf_ offenders failure notification
459411 ]
460412
461413codeActionTests :: TestTree
@@ -481,26 +433,26 @@ codeLensesTests = testGroup "code lenses"
481433watchedFilesTests :: TestTree
482434watchedFilesTests = testGroup "watched files"
483435 [ testSession' "workspace files" $ \sessionDir -> do
484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
487−
488− -- Expect 4 subscriptions (A does not get any because it's VFS):
489− -- - /path-to-workspace/WatchedFilesMissingModule.hs
490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493− liftIO $ length watchedFileRegs @?= 4
436+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
437+ _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
438+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
439+
440+ -- Expect 6 subscriptions (A does not get any because it's VFS):
441+ -- - /path-to-workspace/B.hs
442+ -- - /path-to-workspace/B.lhs
443+ -- - B.hs
444+ -- - B.lhs
445+ -- - src/B.hs
446+ -- - src/B.lhs
447+ liftIO $ length watchedFileRegs @?= 6
494448
495449 , testSession' "non workspace file" $ \sessionDir -> do
496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
450+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
451+ _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
452+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
499453
500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501− -- - /path-to-workspace/WatchedFilesMissingModule.hs
502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503− liftIO $ length watchedFileRegs @?= 2
454+ -- Expect 4 subscriptions:
455+ liftIO $ length watchedFileRegs @?= 4
504456
505457 -- TODO add a test for didChangeWorkspaceFolder
506458 ]
@@ -513,7 +465,7 @@ renameActionTests = testGroup "rename actions"
513465 , "foo :: Int -> Int"
514466 , "foo argName = argNme"
515467 ]
516− doc <- createDoc "Testing.hs" "haskell" content
468+ doc <- openDoc' "Testing.hs" "haskell" content
517469 _ <- waitForDiagnostics
518470 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
519471 executeCodeAction action
@@ -531,7 +483,7 @@ renameActionTests = testGroup "rename actions"
531483 , "foo :: Maybe a -> [a]"
532484 , "foo = maybToList"
533485 ]
534− doc <- createDoc "Testing.hs" "haskell" content
486+ doc <- openDoc' "Testing.hs" "haskell" content
535487 _ <- waitForDiagnostics
536488 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
537489 executeCodeAction action
@@ -549,7 +501,7 @@ renameActionTests = testGroup "rename actions"
549501 , "foo :: Char -> Char -> Char -> Char"
550502 , "foo argument1 argument2 argument3 = argumentX"
551503 ]
552− doc <- createDoc "Testing.hs" "haskell" content
504+ doc <- openDoc' "Testing.hs" "haskell" content
553505 _ <- waitForDiagnostics
554506 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
555507 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -561,7 +513,7 @@ renameActionTests = testGroup "rename actions"
561513 , "monus x y = max 0 (x - y)"
562514 , "foo x y = x `monnus` y"
563515 ]
564− doc <- createDoc "Testing.hs" "haskell" content
516+ doc <- openDoc' "Testing.hs" "haskell" content
565517 _ <- waitForDiagnostics
566518 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567519 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -584,7 +536,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
584536 , "func :: _"
585537 , "func x = x"
586538 ]
587− doc <- createDoc "Testing.hs" "haskell" content
539+ doc <- openDoc' "Testing.hs" "haskell" content
588540 _ <- waitForDiagnostics
589541 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590542 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -604,7 +556,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
604556 , "func :: _"
605557 , "func x y = x + y"
606558 ]
607− doc <- createDoc "Testing.hs" "haskell" content
559+ doc <- openDoc' "Testing.hs" "haskell" content
608560 _ <- waitForDiagnostics
609561 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610562 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -627,7 +579,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
627579 , " y = x * 2"
628580 , " in y"
629581 ]
630− doc <- createDoc "Testing.hs" "haskell" content
582+ doc <- openDoc' "Testing.hs" "haskell" content
631583 _ <- waitForDiagnostics
632584 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633585 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -652,7 +604,7 @@ removeImportTests = testGroup "remove import actions"
652604 let contentA = T.unlines
653605 [ "module ModuleA where"
654606 ]
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
607+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
656608 let contentB = T.unlines
657609 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658610 , "module ModuleB where"
@@ -660,7 +612,7 @@ removeImportTests = testGroup "remove import actions"
660612 , "stuffB :: Integer"
661613 , "stuffB = 123"
662614 ]
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
615+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
664616 _ <- waitForDiagnostics
665617 [CACodeAction action@CodeAction { _title = actionTitle }]
666618 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -678,7 +630,7 @@ removeImportTests = testGroup "remove import actions"
678630 let contentA = T.unlines
679631 [ "module ModuleA where"
680632 ]
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
633+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
682634 let contentB = T.unlines
683635 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684636 , "module ModuleB where"
@@ -686,7 +638,7 @@ removeImportTests = testGroup "remove import actions"
686638 , "stuffB :: Integer"
687639 , "stuffB = 123"
688640 ]
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
641+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
690642 _ <- waitForDiagnostics
691643 [CACodeAction action@CodeAction { _title = actionTitle }]
692644 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -708,14 +660,14 @@ removeImportTests = testGroup "remove import actions"
708660 , "stuffB = 123"
709661 , "stuffC = ()"
710662 ]
711− _docA <- createDoc "ModuleA.hs" "haskell" contentA
663+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
712664 let contentB = T.unlines
713665 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714666 , "module ModuleB where"
715667 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716668 , "main = print stuffB"
717669 ]
718− docB <- createDoc "ModuleB.hs" "haskell" contentB
670+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
719671 _ <- waitForDiagnostics
720672 [CACodeAction action@CodeAction { _title = actionTitle }]
721673 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -737,18 +689,22 @@ removeImportTests = testGroup "remove import actions"
737689 , "stuffB :: Integer"
738690 , "stuffB = 123"
739691 ]
740− _docA <- createDoc "ModuleA.hs" "haskell" contentA
692+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
741693 let contentB = T.unlines
742694 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743695 , "module ModuleB where"
744696 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745697 , "main = print A.stuffB"
746698 ]
747− docB <- createDoc "ModuleB.hs" "haskell" contentB
699+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
748700 _ <- waitForDiagnostics
749701 [CACodeAction action@CodeAction { _title = actionTitle }]
750702 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
703+#if MIN_GHC_API_VERSION(8,6,0)
751704 liftIO $ "Remove !!, <?> from import" @=? actionTitle
705+#else
706+ liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
707+#endif
752708 executeCodeAction action
753709 contentAfterAction <- documentContents docB
754710 let expectedContentAfterAction = T.unlines
@@ -765,14 +721,14 @@ removeImportTests = testGroup "remove import actions"
765721 , "stuffB :: Integer"
766722 , "stuffB = 123"
767723 ]
768− _docA <- createDoc "ModuleA.hs" "haskell" contentA
724+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
769725 let contentB = T.unlines
770726 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771727 , "module ModuleB where"
772728 , "import ModuleA (A(..), stuffB)"
773729 , "main = print stuffB"
774730 ]
775− docB <- createDoc "ModuleB.hs" "haskell" contentB
731+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
776732 _ <- waitForDiagnostics
777733 [CACodeAction action@CodeAction { _title = actionTitle }]
778734 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -792,14 +748,14 @@ removeImportTests = testGroup "remove import actions"
792748 , "data D = A | B"
793749 , "data E = F"
794750 ]
795− _docA <- createDoc "ModuleA.hs" "haskell" contentA
751+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
796752 let contentB = T.unlines
797753 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798754 , "module ModuleB where"
799755 , "import ModuleA (D(A,B), E(F))"
800756 , "main = B"
801757 ]
802− docB <- createDoc "ModuleB.hs" "haskell" contentB
758+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
803759 _ <- waitForDiagnostics
804760 [CACodeAction action@CodeAction { _title = actionTitle }]
805761 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -940,8 +896,8 @@ extendImportTests = testGroup "extend import actions"
940896 ]
941897 where
942898 template contentA contentB range expectedAction expectedContentB = do
943− _docA <- createDoc "ModuleA.hs" "haskell" contentA
944− docB <- createDoc "ModuleB.hs" "haskell" contentB
899+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
900+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
945901 _ <- waitForDiagnostics
946902 CACodeAction action@CodeAction { _title = actionTitle } : _
947903 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -981,8 +937,6 @@ suggestImportTests = testGroup "suggest import actions"
981937 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982938 , test True [] "f = pack" [] "import Data.Text (pack)"
983939 , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984− , test True [] "f = [] & id" [] "import Data.Function ((&))"
985− , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
986940 ]
987941 ]
988942 where
@@ -991,20 +945,19 @@ suggestImportTests = testGroup "suggest import actions"
991945 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992946 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993947 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994− doc <- createDoc "Test.hs" "haskell" before
948+ doc <- openDoc' "Test.hs" "haskell" before
995949 _diags <- waitForDiagnostics
996950 let defLine = length imps + 1
997951 range = Range (Position defLine 0) (Position defLine maxBound)
998952 actions <- getCodeActions doc range
999− if wanted
1000− then do
1001− action <- liftIO $ pickActionWithTitle newImp actions
1002− executeCodeAction action
1003− contentAfterAction <- documentContents doc
1004− liftIO $ after @=? contentAfterAction
1005− else
1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007−
953+ case wanted of
954+ False ->
955+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
956+ True -> do
957+ action <- liftIO $ pickActionWithTitle newImp actions
958+ executeCodeAction action
959+ contentAfterAction <- documentContents doc
960+ liftIO $ after @=? contentAfterAction
1008961
1009962addExtensionTests :: TestTree
1010963addExtensionTests = testGroup "add language extension actions"
@@ -1051,7 +1004,7 @@ addExtensionTests = testGroup "add language extension actions"
10511004 ]
10521005 where
10531006 template initialContent range expectedAction expectedContents = do
1054− doc <- createDoc "Module.hs" "haskell" initialContent
1007+ doc <- openDoc' "Module.hs" "haskell" initialContent
10551008 _ <- waitForDiagnostics
10561009 CACodeAction action@CodeAction { _title = actionTitle } : _
10571010 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1074,7 +1027,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10741027 [""
10751028 ,"someOtherCode = ()"
10761029 ]
1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1030+ docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10781031 _ <- waitForDiagnostics
10791032 CACodeAction action@CodeAction { _title = actionTitle } : _
10801033 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1098,7 +1051,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10981051 [""
10991052 ,"someOtherCode = ()"
11001053 ]
1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1054+ docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
11021055 _ <- waitForDiagnostics
11031056 CACodeAction action@CodeAction { _title = actionTitle } : _
11041057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1137,8 +1090,8 @@ fixConstructorImportTests = testGroup "fix import actions"
11371090 ]
11381091 where
11391092 template contentA contentB range expectedAction expectedContentB = do
1140− _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141− docB <- createDoc "ModuleB.hs" "haskell" contentB
1093+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1094+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
11421095 _diags <- waitForDiagnostics
11431096 CACodeAction action@CodeAction { _title = actionTitle } : _
11441097 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1157,7 +1110,7 @@ importRenameActionTests = testGroup "import rename actions"
11571110 [ "module Testing where"
11581111 , "import Data.Mape"
11591112 ]
1160− doc <- createDoc "Testing.hs" "haskell" content
1113+ doc <- openDoc' "Testing.hs" "haskell" content
11611114 _ <- waitForDiagnostics
11621115 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
11631116 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1194,7 +1147,7 @@ fillTypedHoleTests = let
11941147 newA newB newC = testSession (T.unpack actionTitle) $ do
11951148 let originalCode = sourceCode oldA oldB oldC
11961149 let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
1150+ doc <- openDoc' "Testing.hs" "haskell" originalCode
11981151 _ <- waitForDiagnostics
11991152 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
12001153 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1242,7 +1195,7 @@ addSigActionTests = let
12421195 def >:: sig = testSession (T.unpack def) $ do
12431196 let originalCode = before def
12441197 let expectedCode = after' def sig
1245− doc <- createDoc "Sigs.hs" "haskell" originalCode
1198+ doc <- openDoc' "Sigs.hs" "haskell" originalCode
12461199 _ <- waitForDiagnostics
12471200 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
12481201 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1274,7 +1227,7 @@ addSigLensesTests = let
12741227 sigSession withMissing def sig = testSession (T.unpack def) $ do
12751228 let originalCode = before withMissing def
12761229 let expectedCode = after' withMissing def sig
1277− doc <- createDoc "Sigs.hs" "haskell" originalCode
1230+ doc <- openDoc' "Sigs.hs" "haskell" originalCode
12781231 [CodeLens {_command = Just c}] <- getCodeLenses doc
12791232 executeCommand c
12801233 modifiedCode <- getDocumentEdit doc
@@ -1296,39 +1249,33 @@ addSigLensesTests = let
12961249 ]
12971250 ]
12981251
1299−checkDefs :: [Location] -> Session [Expect] -> Session ()
1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1301−
1302− check (ExpectRange expectedRange) = do
1303− assertNDefinitionsFound 1 defs
1304− assertRangeCorrect (head defs) expectedRange
1305− check (ExpectLocation expectedLocation) = do
1306− assertNDefinitionsFound 1 defs
1307− liftIO $ head defs @?= expectedLocation
1308− check ExpectNoDefinitions = do
1309− assertNDefinitionsFound 0 defs
1310− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311− check _ = pure () -- all other expectations not relevant to getDefinition
1312−
1313− assertNDefinitionsFound :: Int -> [a] -> Session ()
1314− assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1315−
1316− assertRangeCorrect Location{_range = foundRange} expectedRange =
1317− liftIO $ expectedRange @=? foundRange
1318−
1319−
13201252findDefinitionAndHoverTests :: TestTree
13211253findDefinitionAndHoverTests = let
13221254
1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324− doc <- openTestDataDoc (dir </> sourceFilePath)
1255+ tst (get, check) pos targetRange title = testSession title $ do
1256+ doc <- openTestDataDoc sourceFilePath
13251257 found <- get doc pos
13261258 check found targetRange
13271259
1260+ checkDefs :: [Location] -> [Expect] -> Session ()
1261+ checkDefs defs expectations = traverse_ check expectations where
1262+
1263+ check (ExpectRange expectedRange) = do
1264+ assertNDefinitionsFound 1 defs
1265+ assertRangeCorrect (head defs) expectedRange
1266+ check ExpectNoDefinitions = do
1267+ assertNDefinitionsFound 0 defs
1268+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1269+ check _ = pure () -- all other expectations not relevant to getDefinition
1270+
1271+ assertNDefinitionsFound :: Int -> [a] -> Session ()
1272+ assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
13281273
1274+ assertRangeCorrect Location{_range = foundRange} expectedRange =
1275+ liftIO $ expectedRange @=? foundRange
13291276
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
1277+ checkHover :: Maybe Hover -> [Expect] -> Session ()
1278+ checkHover hover expectations = traverse_ check expectations where
13321279
13331280 check expected =
13341281 case hover of
@@ -1371,12 +1318,9 @@ findDefinitionAndHoverTests = let
13711318
13721319 mkFindTests tests = testGroup "get"
13731320 [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
1375− , checkFileCompiles sourceFilePath ]
1321+ , testGroup "hover" $ mapMaybe snd tests ]
13761322
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
1378−
1379− testM runDef runHover look expect title =
1323+ test runDef runHover look expect title =
13801324 ( runDef $ tst def look expect title
13811325 , runHover $ tst hover look expect title ) where
13821326 def = (getDefinitions, checkDefs)
@@ -1384,100 +1328,87 @@ findDefinitionAndHoverTests = let
13841328 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
13851329
13861330 -- search locations expectations on results
1387− fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1388− fffL8 = Position 12 4 ;
1389− fffL14 = Position 18 7 ;
1390− aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1391− dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1392− dcL12 = Position 16 11 ;
1393− xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1394− tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1395− vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1396− opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1397− opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1398− aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1399− b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1400− xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1401− clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1402− clL25 = Position 29 9
1403− eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1404− dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1405− dnbL30 = Position 34 23
1406− lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1407− lclL33 = Position 37 22
1408− mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409− mclL37 = Position 41 1
1410− spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411− docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1331+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1332+ fffL8 = Position 8 4 ;
1333+ fffL14 = Position 14 7 ;
1334+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1335+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1336+ dcL12 = Position 12 11 ;
1337+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1338+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1339+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1340+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1341+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1342+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1343+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1344+ xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1345+ clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1346+ clL25 = Position 25 9
1347+ eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1348+ dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1349+ dnbL30 = Position 30 23
1350+ lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1351+ lclL33 = Position 33 22
1352+ mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1353+ mclL37 = Position 37 1
1354+ spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1355+ docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
14121356 ; constr = [ExpectHoverText ["Monad m"]]
1413− eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414− intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415− tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416− intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417− chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418− txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419− lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420− outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421− innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422− imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423− reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
1357+ eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1358+ intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1359+ tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1360+ intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1361+ chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1362+ txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1363+ lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1364+ outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1365+ innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
14241366 in
14251367 mkFindTests
1426− -- def hover look expect
1427− [ test yes yes fffL4 fff "field in record definition"
1428− , test broken broken fffL8 fff "field in record construction #71"
1429− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430− , test yes yes aaaL14 aaa "top-level name" -- 120
1431− , test yes yes dcL7 tcDC "data constructor record #247"
1432− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1433− , test yes yes tcL6 tcData "type constructor #248" -- 147
1434− , test broken yes xtcL5 xtc "type constructor external #248,249"
1435− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1436− , test yes yes vvL16 vv "plain parameter" -- 120
1437− , test yes yes aL18 apmp "pattern match name" -- 120
1438− , test yes yes opL16 op "top-level operator" -- 120, 123
1439− , test yes yes opL18 opp "parameter operator" -- 120
1440− , test yes yes b'L19 bp "name in backticks" -- 120
1441− , test yes yes clL23 cls "class in instance declaration #250"
1442− , test yes yes clL25 cls "class in signature #250" -- 147
1443− , test broken yes eclL15 ecls "external class in signature #249,250"
1444− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445− , test yes yes dnbL30 dnb "do-notation lookup"
1446− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447− , test yes yes lclL33 lcb "listcomp lookup"
1448− , test yes yes mclL36 mcl "top-level fn 1st clause"
1449− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450− , test yes yes spaceL37 space "top-level fn on space #315"
1451− , test no broken docL41 doc "documentation #7"
1452− , test no yes eitL40 kindE "kind of Either #273"
1453− , test no yes intL40 kindI "kind of Int #273"
1454− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455− , test no yes intL41 litI "literal Int in hover info #274"
1456− , test no yes chrL36 litC "literal Char in hover info #274"
1457− , test no yes txtL8 litT "literal Text in hover info #274"
1458− , test no yes lstL43 litL "literal List in hover info #274"
1459− , test no yes docL41 constr "type constraint in hover info #283"
1460− , test broken broken outL45 outSig "top-level signature #310"
1461− , test broken broken innL48 innSig "inner signature #310"
1462− , testM yes yes imported importedSig "Imported symbol"
1463− , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
1368+ -- def hover look expect
1369+ [ test yes yes fffL4 fff "field in record definition"
1370+ , test broken broken fffL8 fff "field in record construction #71"
1371+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1372+ , test yes yes aaaL14 aaa "top-level name" -- 120
1373+ , test yes yes dcL7 tcDC "data constructor record #247"
1374+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1375+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1376+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1377+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1378+ , test yes yes vvL16 vv "plain parameter" -- 120
1379+ , test yes yes aL18 apmp "pattern match name" -- 120
1380+ , test yes yes opL16 op "top-level operator" -- 120, 123
1381+ , test yes yes opL18 opp "parameter operator" -- 120
1382+ , test yes yes b'L19 bp "name in backticks" -- 120
1383+ , test yes yes clL23 cls "class in instance declaration #250"
1384+ , test yes yes clL25 cls "class in signature #250" -- 147
1385+ , test broken yes eclL15 ecls "external class in signature #249,250"
1386+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1387+ , test yes yes dnbL30 dnb "do-notation lookup"
1388+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1389+ , test yes yes lclL33 lcb "listcomp lookup"
1390+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1391+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1392+ , test yes yes spaceL37 space "top-level fn on space #315"
1393+ , test no broken docL41 doc "documentation #7"
1394+ , test no yes eitL40 kindE "kind of Either #273"
1395+ , test no yes intL40 kindI "kind of Int #273"
1396+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1397+ , test no yes intL41 litI "literal Int in hover info #274"
1398+ , test no yes chrL36 litC "literal Char in hover info #274"
1399+ , test no yes txtL8 litT "literal Text in hover info #274"
1400+ , test no yes lstL43 litL "literal List in hover info #274"
1401+ , test no yes docL41 constr "type constraint in hover info #283"
1402+ , test broken broken outL45 outSig "top-level signature #310"
1403+ , test broken broken innL48 innSig "inner signature #310"
14641404 ]
14651405 where yes, broken :: (TestTree -> Maybe TestTree)
14661406 yes = Just -- test should run and pass
14671407 broken = Just . (`xfail` "known broken")
14681408 no = const Nothing -- don't run this test at all
14691409
1470−checkFileCompiles :: FilePath -> TestTree
1471−checkFileCompiles fp =
1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473− void (openTestDataDoc (dir </> fp))
1474− expectNoMoreDiagnostics 0.5
1475−
1476−
1477−
14781410pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
1411+pluginTests = testSessionWait "plugins" $ do
14811412 let content =
14821413 T.unlines
14831414 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1491,7 +1422,7 @@ pluginTests = (`xfail8101` "known broken (#556)")
14911422 , "foo :: Int -> Int -> Int"
14921423 , "foo a b = a + c"
14931424 ]
1494− _ <- createDoc "Testing.hs" "haskell" content
1425+ _ <- openDoc' "Testing.hs" "haskell" content
14951426 expectDiagnostics
14961427 [ ( "Testing.hs",
14971428 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1518,7 +1449,7 @@ cppTests =
15181449 run $ expectError content (2, 1)
15191450 )
15201451 , testSessionWait "cpp-ghcide" $ do
1521− _ <- createDoc "A.hs" "haskell" $ T.unlines
1452+ _ <- openDoc' "A.hs" "haskell" $ T.unlines
15221453 ["{-# LANGUAGE CPP #-}"
15231454 ,"main ="
15241455 ,"#ifdef __GHCIDE__"
@@ -1532,7 +1463,7 @@ cppTests =
15321463 where
15331464 expectError :: T.Text -> Cursor -> Session ()
15341465 expectError content cursor = do
1535− _ <- createDoc "Testing.hs" "haskell" content
1466+ _ <- openDoc' "Testing.hs" "haskell" content
15361467 expectDiagnostics
15371468 [ ( "Testing.hs",
15381469 [(DsError, cursor, "error: unterminated")]
@@ -1548,7 +1479,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do
15481479 , "module Testing where"
15491480 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
15501481 ]
1551− _ <- createDoc "Testing.hs" "haskell" content
1482+ _ <- openDoc' "Testing.hs" "haskell" content
15521483 expectDiagnostics
15531484 [ ( "Testing.hs",
15541485 [(DsError, (2, 8), "Variable not in scope: z")]
@@ -1581,8 +1512,8 @@ safeTests =
15811512 ,"safeId = trustWorthyId"
15821513 ]
15831514
1584− _ <- createDoc "A.hs" "haskell" sourceA
1585− _ <- createDoc "B.hs" "haskell" sourceB
1515+ _ <- openDoc' "A.hs" "haskell" sourceA
1516+ _ <- openDoc' "B.hs" "haskell" sourceB
15861517 expectNoMoreDiagnostics 1 ]
15871518
15881519thTests :: TestTree
@@ -1610,8 +1541,8 @@ thTests =
16101541 "b :: Integer",
16111542 "b = $(litE $ IntegerL $ a) + n"
16121543 ]
1613− _ <- createDoc "A.hs" "haskell" sourceA
1614− _ <- createDoc "B.hs" "haskell" sourceB
1544+ _ <- openDoc' "A.hs" "haskell" sourceA
1545+ _ <- openDoc' "B.hs" "haskell" sourceB
16151546 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
16161547 , testSessionWait "newtype-closure" $ do
16171548 let sourceA =
@@ -1631,8 +1562,8 @@ thTests =
16311562 ,"import A"
16321563 ,"b :: Int"
16331564 ,"b = $( a )" ]
1634− _ <- createDoc "A.hs" "haskell" sourceA
1635− _ <- createDoc "B.hs" "haskell" sourceB
1565+ _ <- openDoc' "A.hs" "haskell" sourceA
1566+ _ <- openDoc' "B.hs" "haskell" sourceB
16361567 return ()
16371568 ]
16381569
@@ -1641,7 +1572,7 @@ completionTests
16411572 = testGroup "completion"
16421573 [ testSessionWait "variable" $ do
16431574 let source = T.unlines ["module A where", "f = hea"]
1644− docId <- createDoc "A.hs" "haskell" source
1575+ docId <- openDoc' "A.hs" "haskell" source
16451576 compls <- getCompletions docId (Position 1 7)
16461577 liftIO $ map dropDocs compls @?=
16471578 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1653,7 +1584,7 @@ completionTests
16531584 ]
16541585 , testSessionWait "constructor" $ do
16551586 let source = T.unlines ["module A where", "f = Tru"]
1656− docId <- createDoc "A.hs" "haskell" source
1587+ docId <- openDoc' "A.hs" "haskell" source
16571588 compls <- getCompletions docId (Position 1 7)
16581589 liftIO $ map dropDocs compls @?=
16591590 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1665,7 +1596,7 @@ completionTests
16651596 ]
16661597 , testSessionWait "type" $ do
16671598 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668− docId <- createDoc "A.hs" "haskell" source
1599+ docId <- openDoc' "A.hs" "haskell" source
16691600 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
16701601 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
16711602 compls <- getCompletions docId (Position 2 7)
@@ -1682,7 +1613,7 @@ completionTests
16821613 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
16831614 , testSessionWait "qualified" $ do
16841615 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685− docId <- createDoc "A.hs" "haskell" source
1616+ docId <- openDoc' "A.hs" "haskell" source
16861617 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
16871618 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
16881619 compls <- getCompletions docId (Position 2 15)
@@ -1696,7 +1627,7 @@ completionTests
16961627 ]
16971628 , testSessionWait "keyword" $ do
16981629 let source = T.unlines ["module A where", "f = newty"]
1699− docId <- createDoc "A.hs" "haskell" source
1630+ docId <- openDoc' "A.hs" "haskell" source
17001631 compls <- getCompletions docId (Position 1 9)
17011632 liftIO $ compls @?= [keywordItem "newtype"]
17021633 , testSessionWait "type context" $ do
@@ -1705,7 +1636,7 @@ completionTests
17051636 , "module A () where"
17061637 , "f = f"
17071638 ]
1708− docId <- createDoc "A.hs" "haskell" source
1639+ docId <- openDoc' "A.hs" "haskell" source
17091640 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
17101641 changeDoc docId
17111642 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
@@ -1727,7 +1658,6 @@ completionTests
17271658 complItem label kind ty = CompletionItem
17281659 { _label = label
17291660 , _kind = kind
1730− , _tags = List []
17311661 , _detail = (":: " <>) <$> ty
17321662 , _documentation = Nothing
17331663 , _deprecated = Nothing
@@ -1745,7 +1675,6 @@ completionTests
17451675 keywordItem label = CompletionItem
17461676 { _label = label
17471677 , _kind = Just CiKeyword
1748− , _tags = List []
17491678 , _detail = Nothing
17501679 , _documentation = Nothing
17511680 , _deprecated = Nothing
@@ -1773,7 +1702,7 @@ outlineTests = testGroup
17731702 "outline"
17741703 [ testSessionWait "type class" $ do
17751704 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776− docId <- createDoc "A.hs" "haskell" source
1705+ docId <- openDoc' "A.hs" "haskell" source
17771706 symbols <- getDocumentSymbols docId
17781707 liftIO $ symbols @?= Left
17791708 [ moduleSymbol
@@ -1786,7 +1715,7 @@ outlineTests = testGroup
17861715 ]
17871716 , testSessionWait "type class instance " $ do
17881717 let source = T.unlines ["class A a where", "instance A () where"]
1789− docId <- createDoc "A.hs" "haskell" source
1718+ docId <- openDoc' "A.hs" "haskell" source
17901719 symbols <- getDocumentSymbols docId
17911720 liftIO $ symbols @?= Left
17921721 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1794,7 +1723,7 @@ outlineTests = testGroup
17941723 ]
17951724 , testSessionWait "type family" $ do
17961725 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797− docId <- createDoc "A.hs" "haskell" source
1726+ docId <- openDoc' "A.hs" "haskell" source
17981727 symbols <- getDocumentSymbols docId
17991728 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
18001729 , testSessionWait "type family instance " $ do
@@ -1803,7 +1732,7 @@ outlineTests = testGroup
18031732 , "type family A a"
18041733 , "type instance A () = ()"
18051734 ]
1806− docId <- createDoc "A.hs" "haskell" source
1735+ docId <- openDoc' "A.hs" "haskell" source
18071736 symbols <- getDocumentSymbols docId
18081737 liftIO $ symbols @?= Left
18091738 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1811,7 +1740,7 @@ outlineTests = testGroup
18111740 ]
18121741 , testSessionWait "data family" $ do
18131742 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814− docId <- createDoc "A.hs" "haskell" source
1743+ docId <- openDoc' "A.hs" "haskell" source
18151744 symbols <- getDocumentSymbols docId
18161745 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
18171746 , testSessionWait "data family instance " $ do
@@ -1820,7 +1749,7 @@ outlineTests = testGroup
18201749 , "data family A a"
18211750 , "data instance A () = A ()"
18221751 ]
1823− docId <- createDoc "A.hs" "haskell" source
1752+ docId <- openDoc' "A.hs" "haskell" source
18241753 symbols <- getDocumentSymbols docId
18251754 liftIO $ symbols @?= Left
18261755 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1828,36 +1757,36 @@ outlineTests = testGroup
18281757 ]
18291758 , testSessionWait "constant" $ do
18301759 let source = T.unlines ["a = ()"]
1831− docId <- createDoc "A.hs" "haskell" source
1760+ docId <- openDoc' "A.hs" "haskell" source
18321761 symbols <- getDocumentSymbols docId
18331762 liftIO $ symbols @?= Left
18341763 [docSymbol "a" SkFunction (R 0 0 0 6)]
18351764 , testSessionWait "pattern" $ do
18361765 let source = T.unlines ["Just foo = Just 21"]
1837− docId <- createDoc "A.hs" "haskell" source
1766+ docId <- openDoc' "A.hs" "haskell" source
18381767 symbols <- getDocumentSymbols docId
18391768 liftIO $ symbols @?= Left
18401769 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
18411770 , testSessionWait "pattern with type signature" $ do
18421771 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843− docId <- createDoc "A.hs" "haskell" source
1772+ docId <- openDoc' "A.hs" "haskell" source
18441773 symbols <- getDocumentSymbols docId
18451774 liftIO $ symbols @?= Left
18461775 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
18471776 , testSessionWait "function" $ do
18481777 let source = T.unlines ["a x = ()"]
1849− docId <- createDoc "A.hs" "haskell" source
1778+ docId <- openDoc' "A.hs" "haskell" source
18501779 symbols <- getDocumentSymbols docId
18511780 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
18521781 , testSessionWait "type synonym" $ do
18531782 let source = T.unlines ["type A = Bool"]
1854− docId <- createDoc "A.hs" "haskell" source
1783+ docId <- openDoc' "A.hs" "haskell" source
18551784 symbols <- getDocumentSymbols docId
18561785 liftIO $ symbols @?= Left
18571786 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
18581787 , testSessionWait "datatype" $ do
18591788 let source = T.unlines ["data A = C"]
1860− docId <- createDoc "A.hs" "haskell" source
1789+ docId <- openDoc' "A.hs" "haskell" source
18611790 symbols <- getDocumentSymbols docId
18621791 liftIO $ symbols @?= Left
18631792 [ docSymbolWithChildren "A"
@@ -1865,21 +1794,9 @@ outlineTests = testGroup
18651794 (R 0 0 0 10)
18661795 [docSymbol "C" SkConstructor (R 0 9 0 10)]
18671796 ]
1868− , testSessionWait "record fields" $ do
1869− let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870− docId <- createDoc "A.hs" "haskell" source
1871− symbols <- getDocumentSymbols docId
1872− liftIO $ symbols @=? Left
1873− [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874− [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875− [ docSymbol "x" SkField (R 1 2 1 3)
1876− , docSymbol "y" SkField (R 2 4 2 5)
1877− ]
1878− ]
1879− ]
18801797 , testSessionWait "import" $ do
18811798 let source = T.unlines ["import Data.Maybe"]
1882− docId <- createDoc "A.hs" "haskell" source
1799+ docId <- openDoc' "A.hs" "haskell" source
18831800 symbols <- getDocumentSymbols docId
18841801 liftIO $ symbols @?= Left
18851802 [docSymbolWithChildren "imports"
@@ -1890,7 +1807,7 @@ outlineTests = testGroup
18901807 ]
18911808 , testSessionWait "multiple import" $ do
18921809 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893− docId <- createDoc "A.hs" "haskell" source
1810+ docId <- openDoc' "A.hs" "haskell" source
18941811 symbols <- getDocumentSymbols docId
18951812 liftIO $ symbols @?= Left
18961813 [docSymbolWithChildren "imports"
@@ -1905,7 +1822,7 @@ outlineTests = testGroup
19051822 [ "{-# language ForeignFunctionInterface #-}"
19061823 , "foreign import ccall \"a\" a :: Int"
19071824 ]
1908− docId <- createDoc "A.hs" "haskell" source
1825+ docId <- openDoc' "A.hs" "haskell" source
19091826 symbols <- getDocumentSymbols docId
19101827 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
19111828 , testSessionWait "foreign export" $ do
@@ -1913,7 +1830,7 @@ outlineTests = testGroup
19131830 [ "{-# language ForeignFunctionInterface #-}"
19141831 , "foreign export ccall odd :: Int -> Bool"
19151832 ]
1916− docId <- createDoc "A.hs" "haskell" source
1833+ docId <- openDoc' "A.hs" "haskell" source
19171834 symbols <- getDocumentSymbols docId
19181835 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
19191836 ]
@@ -1926,8 +1843,6 @@ outlineTests = testGroup
19261843 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
19271844 docSymbolWithChildren name kind loc cc =
19281845 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1929− docSymbolWithChildren' name kind loc selectionLoc cc =
1930− DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
19311846 moduleSymbol name loc cc = DocumentSymbol name
19321847 Nothing
19331848 SkFile
@@ -1949,16 +1864,8 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
19491864xfail :: TestTree -> String -> TestTree
19501865xfail = flip expectFailBecause
19511866
1952−xfail8101 :: TestTree -> String -> TestTree
1953−#if MIN_GHC_API_VERSION(8,10,0)
1954−xfail8101 = flip expectFailBecause
1955−#else
1956−xfail8101 t _ = t
1957−#endif
1958−
19591867data Expect
19601868 = ExpectRange Range -- Both gotoDef and hover should report this range
1961− | ExpectLocation Location
19621869-- | ExpectDefRange Range -- Only gotoDef should report this range
19631870 | ExpectHoverRange Range -- Only hover should report this range
19641871 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1971,9 +1878,6 @@ data Expect
19711878mkR :: Int -> Int -> Int -> Int -> Expect
19721879mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
19731880
1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976−
19771881haddockTests :: TestTree
19781882haddockTests
19791883 = testGroup "haddock"
@@ -2033,7 +1937,6 @@ cradleTests :: TestTree
20331937cradleTests = testGroup "cradle"
20341938 [testGroup "dependencies" [sessionDepsArePickedUp]
20351939 ,testGroup "loading" [loadCradleOnlyonce]
2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
20371940 ]
20381941
20391942loadCradleOnlyonce :: TestTree
@@ -2048,53 +1951,17 @@ loadCradleOnlyonce = testGroup "load cradle only once"
20481951 test dir
20491952 implicit dir = test dir
20501953 test _dir = do
2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
1954+ doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
20521955 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20531956 liftIO $ length msgs @?= 1
20541957 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
20551958 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20561959 liftIO $ length msgs @?= 0
2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
1960+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"
20581961 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20591962 liftIO $ length msgs @?= 0
20601963
20611964
2062−dependentFileTest :: TestTree
2063−dependentFileTest = testGroup "addDependentFile"
2064− [testGroup "file-changed" [testSession' "test" test]
2065− ]
2066− where
2067− test dir = do
2068− -- If the file contains B then no type error
2069− -- otherwise type error
2070− liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071− let fooContent = T.unlines
2072− [ "{-# LANGUAGE TemplateHaskell #-}"
2073− , "module Foo where"
2074− , "import Language.Haskell.TH.Syntax"
2075− , "foo :: Int"
2076− , "foo = 1 + $(do"
2077− , " qAddDependentFile \"dep-file.txt\""
2078− , " f <- qRunIO (readFile \"dep-file.txt\")"
2079− , " if f == \"B\" then [| 1 |] else lift f)"
2080− ]
2081− let bazContent = T.unlines ["module Baz where", "import Foo"]
2082− _ <-createDoc "Foo.hs" "haskell" fooContent
2083− doc <- createDoc "Baz.hs" "haskell" bazContent
2084− expectDiagnostics
2085− [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086− -- Now modify the dependent file
2087− liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088− let change = TextDocumentContentChangeEvent
2089− { _range = Just (Range (Position 2 0) (Position 2 6))
2090− , _rangeLength = Nothing
2091− , _text = "f = ()"
2092− }
2093− -- Modifying Baz will now trigger Foo to be rebuilt as well
2094− changeDoc doc [change]
2095− expectDiagnostics [("Foo.hs", [])]
2096−
2097−
20981965cradleLoadedMessage :: Session FromServerMessage
20991966cradleLoadedMessage = satisfy $ \case
21001967 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -2103,56 +1970,6 @@ cradleLoadedMessage = satisfy $ \case
21031970cradleLoadedMethod :: T.Text
21041971cradleLoadedMethod = "ghcide/cradle/loaded"
21051972
2106−-- Stack sets this which trips up cabal in the multi-component tests.
2107−-- However, our plugin tests rely on those env vars so we unset it locally.
2108−withoutStackEnv :: IO a -> IO a
2109−withoutStackEnv s =
2110− bracket
2111− (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112− (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2113− (const s)
2114− where vars =
2115− [ "GHC_PACKAGE_PATH"
2116− , "GHC_ENVIRONMENT"
2117− , "HASKELL_DIST_DIR"
2118− , "HASKELL_PACKAGE_SANDBOX"
2119− , "HASKELL_PACKAGE_SANDBOXES"
2120− ]
2121− restore var Nothing = unsetEnv var
2122− restore var (Just val) = setEnv var val True
2123−
2124−simpleMultiTest :: TestTree
2125−simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126− let aPath = dir </> "a/A.hs"
2127− bPath = dir </> "b/B.hs"
2128− aSource <- liftIO $ readFileUtf8 aPath
2129− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130− expectNoMoreDiagnostics 0.5
2131− bSource <- liftIO $ readFileUtf8 bPath
2132− bdoc <- createDoc bPath "haskell" bSource
2133− expectNoMoreDiagnostics 0.5
2134− locs <- getDefinitions bdoc (Position 2 7)
2135− let fooL = mkL adoc 2 0 2 3
2136− checkDefs locs (pure [fooL])
2137− expectNoMoreDiagnostics 0.5
2138−
2139−-- Like simpleMultiTest but open the files in the other order
2140−simpleMultiTest2 :: TestTree
2141−simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142− let aPath = dir </> "a/A.hs"
2143− bPath = dir </> "b/B.hs"
2144− bSource <- liftIO $ readFileUtf8 bPath
2145− bdoc <- createDoc bPath "haskell" bSource
2146− expectNoMoreDiagnostics 5
2147− aSource <- liftIO $ readFileUtf8 aPath
2148− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149− -- Need to have some delay here or the test fails
2150− expectNoMoreDiagnostics 5
2151− locs <- getDefinitions bdoc (Position 2 7)
2152− let fooL = mkL adoc 2 0 2 3
2153− checkDefs locs (pure [fooL])
2154− expectNoMoreDiagnostics 0.5
2155−
21561973sessionDepsArePickedUp :: TestTree
21571974sessionDepsArePickedUp = testSession'
21581975 "session-deps-are-picked-up"
@@ -2162,7 +1979,7 @@ sessionDepsArePickedUp = testSession'
21621979 (dir </> "hie.yaml")
21631980 "cradle: {direct: {arguments: []}}"
21641981 -- Open without OverloadedStrings and expect an error.
2165− doc <- createDoc "Foo.hs" "haskell" fooContent
1982+ doc <- openDoc' "Foo.hs" "haskell" fooContent
21661983 expectDiagnostics
21671984 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
21681985 -- Update hie.yaml to enable OverloadedStrings.
@@ -2197,9 +2014,6 @@ sessionDepsArePickedUp = testSession'
21972014testSession :: String -> Session () -> TestTree
21982015testSession name = testCase name . run
21992016
2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202−
22032017testSession' :: String -> (FilePath -> Session ()) -> TestTree
22042018testSession' name = testCase name . run'
22052019
@@ -2234,19 +2048,6 @@ mkRange a b c d = Range (Position a b) (Position c d)
22342048run :: Session a -> IO a
22352049run s = withTempDir $ \dir -> runInDir dir s
22362050
2237−runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238−runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239− copyTestDataFiles dir prefix
2240− runInDir dir (s dir)
2241−
2242−copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243−copyTestDataFiles dir prefix = do
2244− -- Copy all the test data files to the temporary workspace
2245− testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246− for_ testDataFiles $ \f -> do
2247− createDirectoryIfMissing True $ dir </> takeDirectory f
2248− copyFile ("test/data" </> prefix </> f) (dir </> f)
2249−
22502051run' :: (FilePath -> Session a) -> IO a
22512052run' s = withTempDir $ \dir -> runInDir dir (s dir)
22522053
@@ -2258,7 +2059,6 @@ runInDir dir s = do
22582059 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
22592060 createDirectoryIfMissing True $ dir ++ "/Data"
22602061
2261−
22622062 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
22632063 -- HIE calls getXgdDirectory which assumes that HOME is set.
22642064 -- Only sets HOME if it wasn't already set.
@@ -2276,7 +2076,7 @@ runInDir dir s = do
22762076openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
22772077openTestDataDoc path = do
22782078 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
2079+ openDoc' path "haskell" source
22802080
22812081findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
22822082findCodeActions doc range expectedTitles = do
@@ -2304,19 +2104,24 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
23042104unitTests :: TestTree
23052105unitTests = do
23062106 testGroup "Unit"
2307− [ testCase "empty file path does NOT work with the empty String literal" $
2308− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309− , testCase "empty file path works using toNormalizedFilePath'" $
2310− uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311− , testCase "empty path URI" $ do
2312− Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313− uriScheme @?= "file:"
2314− uriPath @?= ""
2315− , testCase "from empty path URI" $ do
2316− let uri = Uri "file://"
2317− uriToFilePath' uri @?= Just ""
2107+ [ testCase "empty file path" $
2108+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""
23182109 ]
23192110
2111+-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2112+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2113+openDoc' fp name contents = do
2114+ res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2115+ -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2116+ sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2117+ return res
2118+
2119+-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2120+openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2121+-- At the moment this is just LSPTest.openDoc' but it may change in the future
2122+-- when/if lsp-test implements WatchedFiles
2123+openDoc'' = LSPTest.openDoc'
2124+
23202125positionMappingTests :: TestTree
23212126positionMappingTests =
23222127 testGroup "position mapping"
@@ -2486,11 +2291,11 @@ nthLine i r
24862291 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
24872292 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
24882293
2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490−getWatchedFilesSubscriptionsUntil = do
2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2294+getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
2295+getWatchedFilesSubscriptionsUntilProgressEnd = do
2296+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
24922297 return
24932298 [ args
2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2299+ | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
24952300 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
24962301 ]