@@ -10,13 +10,13 @@
1010module Main (main) where
1111
1212import Control.Applicative.Combinators
13−import Control.Exception (catch)
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
1415import Control.Monad
1516import Control.Monad.IO.Class (liftIO)
1617import Data.Aeson (FromJSON, Value)
17−import Data.Char (toLower)
1818import Data.Foldable
19−import Data.List
19+import Data.List.Extra
2020import Data.Rope.UTF16 (Rope)
2121import qualified Data.Rope.UTF16 as Rope
2222import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
@@ -28,14 +28,14 @@ import Development.IDE.Test
2828import Development.IDE.Test.Runfiles
2929import Development.IDE.Types.Location
3030import Development.Shake (getDirectoryFilesIO)
31−import qualified Language.Haskell.LSP.Test as LSPTest
32−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
3332import Language.Haskell.LSP.Messages
3433import Language.Haskell.LSP.Types
3534import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
3636import Language.Haskell.LSP.VFS (applyChange)
3737import Network.URI
38−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
3939import System.FilePath
4040import System.IO.Extra
4141import System.Directory
@@ -49,31 +49,35 @@ import Test.Tasty.QuickCheck
4949import Data.Maybe
5050
5151main :: IO ()
52−main = defaultMainWithRerun $ testGroup "HIE"
53− [ testSession "open close" $ do
54− doc <- openDoc' "Testing.hs" "haskell" ""
55− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
56− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
57− closeDoc doc
58− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
59− , initializeResponseTests
60− , completionTests
61− , cppTests
62− , diagnosticTests
63− , codeActionTests
64− , codeLensesTests
65− , outlineTests
66− , findDefinitionAndHoverTests
67− , pluginTests
68− , preprocessorTests
69− , thTests
70− , safeTests
71− , unitTests
72− , haddockTests
73− , positionMappingTests
74− , watchedFilesTests
75− , cradleTests
76− ]
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+ ]
7781
7882initializeResponseTests :: TestTree
7983initializeResponseTests = withResource acquire release tests where
@@ -129,12 +133,12 @@ initializeResponseTests = withResource acquire release tests where
129133 where
130134 doTest = do
131135 ir <- getInitializeResponse
132− let Just (ExecuteCommandOptions {_commands = List [command]}) = getActual $ innerCaps ir
133− True @=? (T.isSuffixOf "typesignature.add" command)
136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137+ True @=? T.isSuffixOf "typesignature.add" command
134138
135139
136140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
137− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
138142 innerCaps _ = error "this test only expects inner capabilities"
139143
140144 acquire :: IO InitializeResponse
@@ -148,7 +152,7 @@ diagnosticTests :: TestTree
148152diagnosticTests = testGroup "diagnostics"
149153 [ testSessionWait "fix syntax error" $ do
150154 let content = T.unlines [ "module Testing wher" ]
151− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
152156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
153157 let change = TextDocumentContentChangeEvent
154158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -159,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"
159163 expectDiagnostics [("Testing.hs", [])]
160164 , testSessionWait "introduce syntax error" $ do
161165 let content = T.unlines [ "module Testing where" ]
162− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
163167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
164168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
165169 let change = TextDocumentContentChangeEvent
@@ -177,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
177181 , "bar :: Int -> Int -> Int"
178182 , "bar a b = cd + b"
179183 ]
180− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
181185 expectDiagnostics
182186 [ ( "Testing.hs"
183187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -191,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
191195 , "foo :: Int -> String -> Int"
192196 , "foo a b = a + b"
193197 ]
194− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
195199 expectDiagnostics
196200 [ ( "Testing.hs"
197201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -203,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
203207 , "foo :: Int -> String"
204208 , "foo a = _ a"
205209 ]
206− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
207211 expectDiagnostics
208212 [ ( "Testing.hs"
209213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -225,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
225229 [ ("A.hs", [(DsError, (2,4), aMessage)])
226230 , ("B.hs", [(DsError, (3,4), bMessage)])]
227231 deferralTest title binding msg = testSessionWait title $ do
228− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
229− _ <- openDoc' "B.hs" "haskell" sourceB
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
233+ _ <- createDoc "B.hs" "haskell" sourceB
230234 expectDiagnostics $ expectedDs msg
231235 in
232236 [ deferralTest "type error" "True" "Couldn't match expected type"
233237 , deferralTest "typed hole" "_" "Found hole"
234238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
235− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
236239 ]
237240
238241 , testSessionWait "remove required module" $ do
239242 let contentA = T.unlines [ "module ModuleA where" ]
240− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
241244 let contentB = T.unlines
242245 [ "module ModuleB where"
243246 , "import ModuleA"
244247 ]
245− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
246249 let change = TextDocumentContentChangeEvent
247250 { _range = Just (Range (Position 0 0) (Position 0 20))
248251 , _rangeLength = Nothing
@@ -255,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
255258 [ "module ModuleB where"
256259 , "import ModuleA"
257260 ]
258− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
259262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
260263 let contentA = T.unlines [ "module ModuleA where" ]
261− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
262265 expectDiagnostics [("ModuleB.hs", [])]
263266 , testSessionWait "add missing module (non workspace)" $ do
264267 let contentB = T.unlines
265268 [ "module ModuleB where"
266269 , "import ModuleA"
267270 ]
268− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
269272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
270273 let contentA = T.unlines [ "module ModuleA where" ]
271− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
272275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
273276 , testSessionWait "cyclic module dependency" $ do
274277 let contentA = T.unlines
@@ -279,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
279282 [ "module ModuleB where"
280283 , "import ModuleA"
281284 ]
282− _ <- openDoc' "ModuleA.hs" "haskell" contentA
283− _ <- openDoc' "ModuleB.hs" "haskell" contentB
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
284287 expectDiagnostics
285288 [ ( "ModuleA.hs"
286289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -301,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
301304 let contentBboot = T.unlines
302305 [ "module ModuleB where"
303306 ]
304− _ <- openDoc' "ModuleA.hs" "haskell" contentA
305− _ <- openDoc' "ModuleB.hs" "haskell" contentB
306− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
307310 expectDiagnostics []
308311 , testSessionWait "correct reference used with hs-boot" $ do
309312 let contentB = T.unlines
@@ -325,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
325328 -- resolved to the hs-boot file
326329 , "y = x"
327330 ]
328− _ <- openDoc' "ModuleB.hs" "haskell" contentB
329− _ <- openDoc' "ModuleA.hs" "haskell" contentA
330− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
331− _ <- openDoc' "ModuleC.hs" "haskell" contentC
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
332335 expectDiagnostics []
333336 , testSessionWait "redundant import" $ do
334337 let contentA = T.unlines ["module ModuleA where"]
@@ -337,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
337340 , "module ModuleB where"
338341 , "import ModuleA"
339342 ]
340− _ <- openDoc' "ModuleA.hs" "haskell" contentA
341− _ <- openDoc' "ModuleB.hs" "haskell" contentB
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
342345 expectDiagnostics
343346 [ ( "ModuleB.hs"
344347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -360,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
360363 , "wrong1 = ThisList.map"
361364 , "wrong2 = BaseList.x"
362365 ]
363− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
364− _ <- openDoc' "Main.hs" "haskell" mainContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
365368 expectDiagnostics
366369 [ ( "Main.hs"
367370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -376,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
376379 , "foo :: Ord a => a -> Int"
377380 , "foo a = 1"
378381 ]
379− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
380383 expectDiagnostics
381384 [ ( "Foo.hs"
382385 -- The test is to make sure that warnings contain unqualified names
@@ -401,14 +404,14 @@ diagnosticTests = testGroup "diagnostics"
401404 Just pathB <- pure $ uriToFilePath uriB
402405 uriB <- pure $
403406 let (drive, suffix) = splitDrive pathB
404− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
405408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
406409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
407410 uriA <- getDocUri "A/A.hs"
408411 Just pathA <- pure $ uriToFilePath uriA
409412 uriA <- pure $
410413 let (drive, suffix) = splitDrive pathA
411− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
412415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
413416 let a = TextDocumentIdentifier uriA
414417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
@@ -427,13 +430,32 @@ diagnosticTests = testGroup "diagnostics"
427430 , "foo :: Int"
428431 , "foo = 1 {-|-}"
429432 ]
430− _ <- openDoc' "Foo.hs" "haskell" fooContent
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
431434 expectDiagnostics
432435 [ ( "Foo.hs"
433436 , [(DsError, (2, 8), "Parse error on input")
434437 ]
435438 )
436439 ]
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
437459 ]
438460
439461codeActionTests :: TestTree
@@ -459,30 +481,26 @@ codeLensesTests = testGroup "code lenses"
459481watchedFilesTests :: TestTree
460482watchedFilesTests = testGroup "watched files"
461483 [ testSession' "workspace files" $ \sessionDir -> do
462− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
463− _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
464486 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
465487
466− -- Expect 6 subscriptions (A does not get any because it's VFS):
488+ -- Expect 4 subscriptions (A does not get any because it's VFS):
467489 -- - /path-to-workspace/WatchedFilesMissingModule.hs
468490 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
469− -- - WatchedFilesMissingModule.hs
470− -- - WatchedFilesMissingModule.lhs
471− -- - src/WatchedFilesMissingModule.hs
472− -- - src/WatchedFilesMissingModule.lhs
473− liftIO $ length watchedFileRegs @?= 6
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493+ liftIO $ length watchedFileRegs @?= 4
474494
475495 , testSession' "non workspace file" $ \sessionDir -> do
476− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
477− _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
478498 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
479499
480− -- Expect 4 subscriptions (/tmp does not get any as it is out of the workspace):
500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
481501 -- - /path-to-workspace/WatchedFilesMissingModule.hs
482502 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
483− -- - WatchedFilesMissingModule.hs
484− -- - WatchedFilesMissingModule.lhs
485− liftIO $ length watchedFileRegs @?= 4
503+ liftIO $ length watchedFileRegs @?= 2
486504
487505 -- TODO add a test for didChangeWorkspaceFolder
488506 ]
@@ -495,7 +513,7 @@ renameActionTests = testGroup "rename actions"
495513 , "foo :: Int -> Int"
496514 , "foo argName = argNme"
497515 ]
498− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
499517 _ <- waitForDiagnostics
500518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
501519 executeCodeAction action
@@ -513,7 +531,7 @@ renameActionTests = testGroup "rename actions"
513531 , "foo :: Maybe a -> [a]"
514532 , "foo = maybToList"
515533 ]
516− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
517535 _ <- waitForDiagnostics
518536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
519537 executeCodeAction action
@@ -531,7 +549,7 @@ renameActionTests = testGroup "rename actions"
531549 , "foo :: Char -> Char -> Char -> Char"
532550 , "foo argument1 argument2 argument3 = argumentX"
533551 ]
534− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
535553 _ <- waitForDiagnostics
536554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
537555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -543,7 +561,7 @@ renameActionTests = testGroup "rename actions"
543561 , "monus x y = max 0 (x - y)"
544562 , "foo x y = x `monnus` y"
545563 ]
546− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
547565 _ <- waitForDiagnostics
548566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
549567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -566,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
566584 , "func :: _"
567585 , "func x = x"
568586 ]
569− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
570588 _ <- waitForDiagnostics
571589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
572590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -586,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
586604 , "func :: _"
587605 , "func x y = x + y"
588606 ]
589− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
590608 _ <- waitForDiagnostics
591609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
592610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -609,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
609627 , " y = x * 2"
610628 , " in y"
611629 ]
612− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
613631 _ <- waitForDiagnostics
614632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
615633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -634,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
634652 let contentA = T.unlines
635653 [ "module ModuleA where"
636654 ]
637− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
638656 let contentB = T.unlines
639657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
640658 , "module ModuleB where"
@@ -642,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
642660 , "stuffB :: Integer"
643661 , "stuffB = 123"
644662 ]
645− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
646664 _ <- waitForDiagnostics
647665 [CACodeAction action@CodeAction { _title = actionTitle }]
648666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -660,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
660678 let contentA = T.unlines
661679 [ "module ModuleA where"
662680 ]
663− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
664682 let contentB = T.unlines
665683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
666684 , "module ModuleB where"
@@ -668,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
668686 , "stuffB :: Integer"
669687 , "stuffB = 123"
670688 ]
671− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
672690 _ <- waitForDiagnostics
673691 [CACodeAction action@CodeAction { _title = actionTitle }]
674692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -690,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
690708 , "stuffB = 123"
691709 , "stuffC = ()"
692710 ]
693− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
694712 let contentB = T.unlines
695713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
696714 , "module ModuleB where"
697715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
698716 , "main = print stuffB"
699717 ]
700− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
701719 _ <- waitForDiagnostics
702720 [CACodeAction action@CodeAction { _title = actionTitle }]
703721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -719,22 +737,18 @@ removeImportTests = testGroup "remove import actions"
719737 , "stuffB :: Integer"
720738 , "stuffB = 123"
721739 ]
722− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
723741 let contentB = T.unlines
724742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
725743 , "module ModuleB where"
726744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
727745 , "main = print A.stuffB"
728746 ]
729− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
730748 _ <- waitForDiagnostics
731749 [CACodeAction action@CodeAction { _title = actionTitle }]
732750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
733−#if MIN_GHC_API_VERSION(8,6,0)
734751 liftIO $ "Remove !!, <?> from import" @=? actionTitle
735−#else
736− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
737−#endif
738752 executeCodeAction action
739753 contentAfterAction <- documentContents docB
740754 let expectedContentAfterAction = T.unlines
@@ -751,14 +765,14 @@ removeImportTests = testGroup "remove import actions"
751765 , "stuffB :: Integer"
752766 , "stuffB = 123"
753767 ]
754− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
755769 let contentB = T.unlines
756770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
757771 , "module ModuleB where"
758772 , "import ModuleA (A(..), stuffB)"
759773 , "main = print stuffB"
760774 ]
761− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
762776 _ <- waitForDiagnostics
763777 [CACodeAction action@CodeAction { _title = actionTitle }]
764778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -778,14 +792,14 @@ removeImportTests = testGroup "remove import actions"
778792 , "data D = A | B"
779793 , "data E = F"
780794 ]
781− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
782796 let contentB = T.unlines
783797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
784798 , "module ModuleB where"
785799 , "import ModuleA (D(A,B), E(F))"
786800 , "main = B"
787801 ]
788− docB <- openDoc' "ModuleB.hs" "haskell" contentB
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
789803 _ <- waitForDiagnostics
790804 [CACodeAction action@CodeAction { _title = actionTitle }]
791805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -926,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
926940 ]
927941 where
928942 template contentA contentB range expectedAction expectedContentB = do
929− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
930− docB <- openDoc' "ModuleB.hs" "haskell" contentB
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
931945 _ <- waitForDiagnostics
932946 CACodeAction action@CodeAction { _title = actionTitle } : _
933947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -967,6 +981,8 @@ suggestImportTests = testGroup "suggest import actions"
967981 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
968982 , test True [] "f = pack" [] "import Data.Text (pack)"
969983 , 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 ((&))"
970986 ]
971987 ]
972988 where
@@ -975,19 +991,20 @@ suggestImportTests = testGroup "suggest import actions"
975991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
976992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
977993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
978− doc <- openDoc' "Test.hs" "haskell" before
994+ doc <- createDoc "Test.hs" "haskell" before
979995 _diags <- waitForDiagnostics
980996 let defLine = length imps + 1
981997 range = Range (Position defLine 0) (Position defLine maxBound)
982998 actions <- getCodeActions doc range
983− case wanted of
984− False ->
985− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
986− True -> do
987− action <- liftIO $ pickActionWithTitle newImp actions
988− executeCodeAction action
989− contentAfterAction <- documentContents doc
990− liftIO $ after @=? contentAfterAction
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+
9911008
9921009addExtensionTests :: TestTree
9931010addExtensionTests = testGroup "add language extension actions"
@@ -1034,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
10341051 ]
10351052 where
10361053 template initialContent range expectedAction expectedContents = do
1037− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
10381055 _ <- waitForDiagnostics
10391056 CACodeAction action@CodeAction { _title = actionTitle } : _
10401057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1057,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10571074 [""
10581075 ,"someOtherCode = ()"
10591076 ]
1060− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10611078 _ <- waitForDiagnostics
10621079 CACodeAction action@CodeAction { _title = actionTitle } : _
10631080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1081,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10811098 [""
10821099 ,"someOtherCode = ()"
10831100 ]
1084− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10851102 _ <- waitForDiagnostics
10861103 CACodeAction action@CodeAction { _title = actionTitle } : _
10871104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1120,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
11201137 ]
11211138 where
11221139 template contentA contentB range expectedAction expectedContentB = do
1123− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1124− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
11251142 _diags <- waitForDiagnostics
11261143 CACodeAction action@CodeAction { _title = actionTitle } : _
11271144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1140,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
11401157 [ "module Testing where"
11411158 , "import Data.Mape"
11421159 ]
1143− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
11441161 _ <- waitForDiagnostics
11451162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
11461163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1177,7 +1194,7 @@ fillTypedHoleTests = let
11771194 newA newB newC = testSession (T.unpack actionTitle) $ do
11781195 let originalCode = sourceCode oldA oldB oldC
11791196 let expectedCode = sourceCode newA newB newC
1180− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
11811198 _ <- waitForDiagnostics
11821199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
11831200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1225,7 +1242,7 @@ addSigActionTests = let
12251242 def >:: sig = testSession (T.unpack def) $ do
12261243 let originalCode = before def
12271244 let expectedCode = after' def sig
1228− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
12291246 _ <- waitForDiagnostics
12301247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
12311248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1257,7 +1274,7 @@ addSigLensesTests = let
12571274 sigSession withMissing def sig = testSession (T.unpack def) $ do
12581275 let originalCode = before withMissing def
12591276 let expectedCode = after' withMissing def sig
1260− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
12611278 [CodeLens {_command = Just c}] <- getCodeLenses doc
12621279 executeCommand c
12631280 modifiedCode <- getDocumentEdit doc
@@ -1279,27 +1296,19 @@ addSigLensesTests = let
12791296 ]
12801297 ]
12811298
1282−findDefinitionAndHoverTests :: TestTree
1283−findDefinitionAndHoverTests = let
1284−
1285− tst (get, check) pos targetRange title = testSession title $ do
1286− doc <- openTestDataDoc sourceFilePath
1287− found <- get doc pos
1288− check found targetRange
1289−
1290− checkDefs :: [Location] -> Session [Expect] -> Session ()
1291− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
12921301
1293− check (ExpectRange expectedRange) = do
1294− assertNDefinitionsFound 1 defs
1295− assertRangeCorrect (head defs) expectedRange
1296− check (ExpectLocation expectedLocation) = do
1297− assertNDefinitionsFound 1 defs
1298− liftIO $ head defs @?= expectedLocation
1299− check ExpectNoDefinitions = do
1300− assertNDefinitionsFound 0 defs
1301− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1302− check _ = pure () -- all other expectations not relevant to getDefinition
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
13031312
13041313 assertNDefinitionsFound :: Int -> [a] -> Session ()
13051314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1307,6 +1316,17 @@ findDefinitionAndHoverTests = let
13071316 assertRangeCorrect Location{_range = foundRange} expectedRange =
13081317 liftIO $ expectedRange @=? foundRange
13091318
1319+
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1322+
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1327+
1328+
1329+
13101330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()
13111331 checkHover hover expectations = traverse_ check =<< expectations where
13121332
@@ -1351,7 +1371,8 @@ findDefinitionAndHoverTests = let
13511371
13521372 mkFindTests tests = testGroup "get"
13531373 [ testGroup "definition" $ mapMaybe fst tests
1354− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
13551376
13561377 test runDef runHover look expect = testM runDef runHover look (return expect)
13571378
@@ -1446,8 +1467,17 @@ findDefinitionAndHoverTests = let
14461467 broken = Just . (`xfail` "known broken")
14471468 no = const Nothing -- don't run this test at all
14481469
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+
14491478pluginTests :: TestTree
1450−pluginTests = testSessionWait "plugins" $ do
1479+pluginTests = (`xfail8101` "known broken (#556)")
1480+ $ testSessionWait "plugins" $ do
14511481 let content =
14521482 T.unlines
14531483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1461,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
14611491 , "foo :: Int -> Int -> Int"
14621492 , "foo a b = a + c"
14631493 ]
1464− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
14651495 expectDiagnostics
14661496 [ ( "Testing.hs",
14671497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1488,7 +1518,7 @@ cppTests =
14881518 run $ expectError content (2, 1)
14891519 )
14901520 , testSessionWait "cpp-ghcide" $ do
1491− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
14921522 ["{-# LANGUAGE CPP #-}"
14931523 ,"main ="
14941524 ,"#ifdef __GHCIDE__"
@@ -1502,7 +1532,7 @@ cppTests =
15021532 where
15031533 expectError :: T.Text -> Cursor -> Session ()
15041534 expectError content cursor = do
1505− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
15061536 expectDiagnostics
15071537 [ ( "Testing.hs",
15081538 [(DsError, cursor, "error: unterminated")]
@@ -1518,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do
15181548 , "module Testing where"
15191549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
15201550 ]
1521− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
15221552 expectDiagnostics
15231553 [ ( "Testing.hs",
15241554 [(DsError, (2, 8), "Variable not in scope: z")]
@@ -1551,8 +1581,8 @@ safeTests =
15511581 ,"safeId = trustWorthyId"
15521582 ]
15531583
1554− _ <- openDoc' "A.hs" "haskell" sourceA
1555− _ <- openDoc' "B.hs" "haskell" sourceB
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
15561586 expectNoMoreDiagnostics 1 ]
15571587
15581588thTests :: TestTree
@@ -1580,8 +1610,8 @@ thTests =
15801610 "b :: Integer",
15811611 "b = $(litE $ IntegerL $ a) + n"
15821612 ]
1583− _ <- openDoc' "A.hs" "haskell" sourceA
1584− _ <- openDoc' "B.hs" "haskell" sourceB
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1614+ _ <- createDoc "B.hs" "haskell" sourceB
15851615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
15861616 , testSessionWait "newtype-closure" $ do
15871617 let sourceA =
@@ -1601,8 +1631,8 @@ thTests =
16011631 ,"import A"
16021632 ,"b :: Int"
16031633 ,"b = $( a )" ]
1604− _ <- openDoc' "A.hs" "haskell" sourceA
1605− _ <- openDoc' "B.hs" "haskell" sourceB
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
16061636 return ()
16071637 ]
16081638
@@ -1611,7 +1641,7 @@ completionTests
16111641 = testGroup "completion"
16121642 [ testSessionWait "variable" $ do
16131643 let source = T.unlines ["module A where", "f = hea"]
1614− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
16151645 compls <- getCompletions docId (Position 1 7)
16161646 liftIO $ map dropDocs compls @?=
16171647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1623,7 +1653,7 @@ completionTests
16231653 ]
16241654 , testSessionWait "constructor" $ do
16251655 let source = T.unlines ["module A where", "f = Tru"]
1626− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
16271657 compls <- getCompletions docId (Position 1 7)
16281658 liftIO $ map dropDocs compls @?=
16291659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1635,7 +1665,7 @@ completionTests
16351665 ]
16361666 , testSessionWait "type" $ do
16371667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1638− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
16391669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
16401670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
16411671 compls <- getCompletions docId (Position 2 7)
@@ -1652,7 +1682,7 @@ completionTests
16521682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
16531683 , testSessionWait "qualified" $ do
16541684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1655− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
16561686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
16571687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
16581688 compls <- getCompletions docId (Position 2 15)
@@ -1666,7 +1696,7 @@ completionTests
16661696 ]
16671697 , testSessionWait "keyword" $ do
16681698 let source = T.unlines ["module A where", "f = newty"]
1669− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
16701700 compls <- getCompletions docId (Position 1 9)
16711701 liftIO $ compls @?= [keywordItem "newtype"]
16721702 , testSessionWait "type context" $ do
@@ -1675,7 +1705,7 @@ completionTests
16751705 , "module A () where"
16761706 , "f = f"
16771707 ]
1678− docId <- openDoc' "A.hs" "haskell" source
1708+ docId <- createDoc "A.hs" "haskell" source
16791709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
16801710 changeDoc docId
16811711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
@@ -1743,7 +1773,7 @@ outlineTests = testGroup
17431773 "outline"
17441774 [ testSessionWait "type class" $ do
17451775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1746− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
17471777 symbols <- getDocumentSymbols docId
17481778 liftIO $ symbols @?= Left
17491779 [ moduleSymbol
@@ -1756,7 +1786,7 @@ outlineTests = testGroup
17561786 ]
17571787 , testSessionWait "type class instance " $ do
17581788 let source = T.unlines ["class A a where", "instance A () where"]
1759− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
17601790 symbols <- getDocumentSymbols docId
17611791 liftIO $ symbols @?= Left
17621792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1764,7 +1794,7 @@ outlineTests = testGroup
17641794 ]
17651795 , testSessionWait "type family" $ do
17661796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1767− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
17681798 symbols <- getDocumentSymbols docId
17691799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
17701800 , testSessionWait "type family instance " $ do
@@ -1773,7 +1803,7 @@ outlineTests = testGroup
17731803 , "type family A a"
17741804 , "type instance A () = ()"
17751805 ]
1776− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
17771807 symbols <- getDocumentSymbols docId
17781808 liftIO $ symbols @?= Left
17791809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1781,7 +1811,7 @@ outlineTests = testGroup
17811811 ]
17821812 , testSessionWait "data family" $ do
17831813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1784− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
17851815 symbols <- getDocumentSymbols docId
17861816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
17871817 , testSessionWait "data family instance " $ do
@@ -1790,7 +1820,7 @@ outlineTests = testGroup
17901820 , "data family A a"
17911821 , "data instance A () = A ()"
17921822 ]
1793− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
17941824 symbols <- getDocumentSymbols docId
17951825 liftIO $ symbols @?= Left
17961826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1798,36 +1828,36 @@ outlineTests = testGroup
17981828 ]
17991829 , testSessionWait "constant" $ do
18001830 let source = T.unlines ["a = ()"]
1801− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
18021832 symbols <- getDocumentSymbols docId
18031833 liftIO $ symbols @?= Left
18041834 [docSymbol "a" SkFunction (R 0 0 0 6)]
18051835 , testSessionWait "pattern" $ do
18061836 let source = T.unlines ["Just foo = Just 21"]
1807− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
18081838 symbols <- getDocumentSymbols docId
18091839 liftIO $ symbols @?= Left
18101840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
18111841 , testSessionWait "pattern with type signature" $ do
18121842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1813− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
18141844 symbols <- getDocumentSymbols docId
18151845 liftIO $ symbols @?= Left
18161846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
18171847 , testSessionWait "function" $ do
18181848 let source = T.unlines ["a x = ()"]
1819− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
18201850 symbols <- getDocumentSymbols docId
18211851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
18221852 , testSessionWait "type synonym" $ do
18231853 let source = T.unlines ["type A = Bool"]
1824− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
18251855 symbols <- getDocumentSymbols docId
18261856 liftIO $ symbols @?= Left
18271857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
18281858 , testSessionWait "datatype" $ do
18291859 let source = T.unlines ["data A = C"]
1830− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
18311861 symbols <- getDocumentSymbols docId
18321862 liftIO $ symbols @?= Left
18331863 [ docSymbolWithChildren "A"
@@ -1835,9 +1865,21 @@ outlineTests = testGroup
18351865 (R 0 0 0 10)
18361866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
18371867 ]
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+ ]
18381880 , testSessionWait "import" $ do
18391881 let source = T.unlines ["import Data.Maybe"]
1840− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
18411883 symbols <- getDocumentSymbols docId
18421884 liftIO $ symbols @?= Left
18431885 [docSymbolWithChildren "imports"
@@ -1848,7 +1890,7 @@ outlineTests = testGroup
18481890 ]
18491891 , testSessionWait "multiple import" $ do
18501892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1851− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
18521894 symbols <- getDocumentSymbols docId
18531895 liftIO $ symbols @?= Left
18541896 [docSymbolWithChildren "imports"
@@ -1863,7 +1905,7 @@ outlineTests = testGroup
18631905 [ "{-# language ForeignFunctionInterface #-}"
18641906 , "foreign import ccall \"a\" a :: Int"
18651907 ]
1866− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
18671909 symbols <- getDocumentSymbols docId
18681910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
18691911 , testSessionWait "foreign export" $ do
@@ -1871,7 +1913,7 @@ outlineTests = testGroup
18711913 [ "{-# language ForeignFunctionInterface #-}"
18721914 , "foreign export ccall odd :: Int -> Bool"
18731915 ]
1874− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
18751917 symbols <- getDocumentSymbols docId
18761918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
18771919 ]
@@ -1884,6 +1926,8 @@ outlineTests = testGroup
18841926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
18851927 docSymbolWithChildren name kind loc cc =
18861928 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)
18871931 moduleSymbol name loc cc = DocumentSymbol name
18881932 Nothing
18891933 SkFile
@@ -1905,6 +1949,13 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
19051949xfail :: TestTree -> String -> TestTree
19061950xfail = flip expectFailBecause
19071951
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+
19081959data Expect
19091960 = ExpectRange Range -- Both gotoDef and hover should report this range
19101961 | ExpectLocation Location
@@ -1982,6 +2033,7 @@ cradleTests :: TestTree
19822033cradleTests = testGroup "cradle"
19832034 [testGroup "dependencies" [sessionDepsArePickedUp]
19842035 ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
19852037 ]
19862038
19872039loadCradleOnlyonce :: TestTree
@@ -1996,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"
19962048 test dir
19972049 implicit dir = test dir
19982050 test _dir = do
1999− doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
20002052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20012053 liftIO $ length msgs @?= 1
20022054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
20032055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20042056 liftIO $ length msgs @?= 0
2005− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
20062058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20072059 liftIO $ length msgs @?= 0
20082060
20092061
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+
20102098cradleLoadedMessage :: Session FromServerMessage
20112099cradleLoadedMessage = satisfy $ \case
20122100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -2015,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case
20152103cradleLoadedMethod :: T.Text
20162104cradleLoadedMethod = "ghcide/cradle/loaded"
20172105
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+
20182156sessionDepsArePickedUp :: TestTree
20192157sessionDepsArePickedUp = testSession'
20202158 "session-deps-are-picked-up"
@@ -2024,7 +2162,7 @@ sessionDepsArePickedUp = testSession'
20242162 (dir </> "hie.yaml")
20252163 "cradle: {direct: {arguments: []}}"
20262164 -- Open without OverloadedStrings and expect an error.
2027− doc <- openDoc' "Foo.hs" "haskell" fooContent
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
20282166 expectDiagnostics
20292167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
20302168 -- Update hie.yaml to enable OverloadedStrings.
@@ -2059,6 +2197,9 @@ sessionDepsArePickedUp = testSession'
20592197testSession :: String -> Session () -> TestTree
20602198testSession name = testCase name . run
20612199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
20622203testSession' :: String -> (FilePath -> Session ()) -> TestTree
20632204testSession' name = testCase name . run'
20642205
@@ -2093,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)
20932234run :: Session a -> IO a
20942235run s = withTempDir $ \dir -> runInDir dir s
20952236
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+
20962250run' :: (FilePath -> Session a) -> IO a
20972251run' s = withTempDir $ \dir -> runInDir dir (s dir)
20982252
@@ -2104,11 +2258,6 @@ runInDir dir s = do
21042258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
21052259 createDirectoryIfMissing True $ dir ++ "/Data"
21062260
2107− -- Copy all the test data files to the temporary workspace
2108− testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]
2109− for_ testDataFiles $ \f -> do
2110− createDirectoryIfMissing True $ dir </> takeDirectory f
2111− copyFile ("test/data" </> f) (dir </> f)
21122261
21132262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
21142263 -- HIE calls getXgdDirectory which assumes that HOME is set.
@@ -2127,7 +2276,7 @@ runInDir dir s = do
21272276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
21282277openTestDataDoc path = do
21292278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2130− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
21312280
21322281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
21332282findCodeActions doc range expectedTitles = do
@@ -2168,20 +2317,6 @@ unitTests = do
21682317 uriToFilePath' uri @?= Just ""
21692318 ]
21702319
2171−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2172−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2173−openDoc' fp name contents = do
2174− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2175− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2176− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2177− return res
2178−
2179−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2180−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2181−-- At the moment this is just LSPTest.openDoc' but it may change in the future
2182−-- when/if lsp-test implements WatchedFiles
2183−openDoc'' = LSPTest.openDoc'
2184−
21852320positionMappingTests :: TestTree
21862321positionMappingTests =
21872322 testGroup "position mapping"
@@ -2356,6 +2491,6 @@ getWatchedFilesSubscriptionsUntil = do
23562491 msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
23572492 return
23582493 [ args
2359− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
23602495 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
23612496 ]