@@ -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,30 @@
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)
3734import Network.URI
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
35+import System.Environment.Blank (setEnv)
3936import System.FilePath
4037import System.IO.Extra
4138import System.Directory
@@ -49,35 +46,31 @@ import Test.Tasty.QuickCheck
4946import Data.Maybe
5047
5148main :: 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− ]
49+main = defaultMainWithRerun $ testGroup "HIE"
50+ [ testSession "open close" $ do
51+ doc <- openDoc' "Testing.hs" "haskell" ""
52+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
53+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
54+ closeDoc doc
55+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
56+ , initializeResponseTests
57+ , completionTests
58+ , cppTests
59+ , diagnosticTests
60+ , codeActionTests
61+ , codeLensesTests
62+ , outlineTests
63+ , findDefinitionAndHoverTests
64+ , pluginTests
65+ , preprocessorTests
66+ , thTests
67+ , safeTests
68+ , unitTests
69+ , haddockTests
70+ , positionMappingTests
71+ , watchedFilesTests
72+ , cradleTests
73+ ]
8174
8275initializeResponseTests :: TestTree
8376initializeResponseTests = withResource acquire release tests where
@@ -112,7 +105,7 @@ initializeResponseTests = withResource acquire release tests where
112105 , chk "NO doc link" _documentLinkProvider Nothing
113106 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114107 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
108+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116109 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
117110 , chk "NO experimental" _experimental Nothing
118111 ] where
@@ -128,17 +121,8 @@ initializeResponseTests = withResource acquire release tests where
128121 chk title getActual expected =
129122 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
130123
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−
140124 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
125+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
142126 innerCaps _ = error "this test only expects inner capabilities"
143127
144128 acquire :: IO InitializeResponse
@@ -152,7 +136,7 @@ diagnosticTests :: TestTree
152136diagnosticTests = testGroup "diagnostics"
153137 [ testSessionWait "fix syntax error" $ do
154138 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
139+ doc <- openDoc' "Testing.hs" "haskell" content
156140 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
157141 let change = TextDocumentContentChangeEvent
158142 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -163,7 +147,7 @@ diagnosticTests = testGroup "diagnostics"
163147 expectDiagnostics [("Testing.hs", [])]
164148 , testSessionWait "introduce syntax error" $ do
165149 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
150+ doc <- openDoc' "Testing.hs" "haskell" content
167151 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
168152 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
169153 let change = TextDocumentContentChangeEvent
@@ -181,7 +165,7 @@ diagnosticTests = testGroup "diagnostics"
181165 , "bar :: Int -> Int -> Int"
182166 , "bar a b = cd + b"
183167 ]
184− _ <- createDoc "Testing.hs" "haskell" content
168+ _ <- openDoc' "Testing.hs" "haskell" content
185169 expectDiagnostics
186170 [ ( "Testing.hs"
187171 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -195,7 +179,7 @@ diagnosticTests = testGroup "diagnostics"
195179 , "foo :: Int -> String -> Int"
196180 , "foo a b = a + b"
197181 ]
198− _ <- createDoc "Testing.hs" "haskell" content
182+ _ <- openDoc' "Testing.hs" "haskell" content
199183 expectDiagnostics
200184 [ ( "Testing.hs"
201185 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -207,7 +191,7 @@ diagnosticTests = testGroup "diagnostics"
207191 , "foo :: Int -> String"
208192 , "foo a = _ a"
209193 ]
210− _ <- createDoc "Testing.hs" "haskell" content
194+ _ <- openDoc' "Testing.hs" "haskell" content
211195 expectDiagnostics
212196 [ ( "Testing.hs"
213197 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -229,23 +213,24 @@ diagnosticTests = testGroup "diagnostics"
229213 [ ("A.hs", [(DsError, (2,4), aMessage)])
230214 , ("B.hs", [(DsError, (3,4), bMessage)])]
231215 deferralTest title binding msg = testSessionWait title $ do
232− _ <- createDoc "A.hs" "haskell" $ sourceA binding
233− _ <- createDoc "B.hs" "haskell" sourceB
216+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding
217+ _ <- openDoc' "B.hs" "haskell" sourceB
234218 expectDiagnostics $ expectedDs msg
235219 in
236220 [ deferralTest "type error" "True" "Couldn't match expected type"
237221 , deferralTest "typed hole" "_" "Found hole"
238222 , deferralTest "out of scope var" "unbound" "Variable not in scope"
223+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"
239224 ]
240225
241226 , testSessionWait "remove required module" $ do
242227 let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
228+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
244229 let contentB = T.unlines
245230 [ "module ModuleB where"
246231 , "import ModuleA"
247232 ]
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
233+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
249234 let change = TextDocumentContentChangeEvent
250235 { _range = Just (Range (Position 0 0) (Position 0 20))
251236 , _rangeLength = Nothing
@@ -258,20 +243,20 @@ diagnosticTests = testGroup "diagnostics"
258243 [ "module ModuleB where"
259244 , "import ModuleA"
260245 ]
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
246+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
262247 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263248 let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
249+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
265250 expectDiagnostics [("ModuleB.hs", [])]
266251 , testSessionWait "add missing module (non workspace)" $ do
267252 let contentB = T.unlines
268253 [ "module ModuleB where"
269254 , "import ModuleA"
270255 ]
271− _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
256+ _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
272257 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273258 let contentA = T.unlines [ "module ModuleA where" ]
274− _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
259+ _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
275260 expectDiagnostics [("/tmp/ModuleB.hs", [])]
276261 , testSessionWait "cyclic module dependency" $ do
277262 let contentA = T.unlines
@@ -282,8 +267,8 @@ diagnosticTests = testGroup "diagnostics"
282267 [ "module ModuleB where"
283268 , "import ModuleA"
284269 ]
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
270+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
271+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
287272 expectDiagnostics
288273 [ ( "ModuleA.hs"
289274 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -304,9 +289,9 @@ diagnosticTests = testGroup "diagnostics"
304289 let contentBboot = T.unlines
305290 [ "module ModuleB where"
306291 ]
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
292+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
293+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
294+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
310295 expectDiagnostics []
311296 , testSessionWait "correct reference used with hs-boot" $ do
312297 let contentB = T.unlines
@@ -328,10 +313,10 @@ diagnosticTests = testGroup "diagnostics"
328313 -- resolved to the hs-boot file
329314 , "y = x"
330315 ]
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
316+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
317+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
318+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
319+ _ <- openDoc' "ModuleC.hs" "haskell" contentC
335320 expectDiagnostics []
336321 , testSessionWait "redundant import" $ do
337322 let contentA = T.unlines ["module ModuleA where"]
@@ -340,8 +325,8 @@ diagnosticTests = testGroup "diagnostics"
340325 , "module ModuleB where"
341326 , "import ModuleA"
342327 ]
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
328+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
329+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
345330 expectDiagnostics
346331 [ ( "ModuleB.hs"
347332 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -363,8 +348,8 @@ diagnosticTests = testGroup "diagnostics"
363348 , "wrong1 = ThisList.map"
364349 , "wrong2 = BaseList.x"
365350 ]
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
351+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
352+ _ <- openDoc' "Main.hs" "haskell" mainContent
368353 expectDiagnostics
369354 [ ( "Main.hs"
370355 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -379,7 +364,7 @@ diagnosticTests = testGroup "diagnostics"
379364 , "foo :: Ord a => a -> Int"
380365 , "foo a = 1"
381366 ]
382− _ <- createDoc "Foo.hs" "haskell" fooContent
367+ _ <- openDoc' "Foo.hs" "haskell" fooContent
383368 expectDiagnostics
384369 [ ( "Foo.hs"
385370 -- The test is to make sure that warnings contain unqualified names
@@ -404,18 +389,18 @@ diagnosticTests = testGroup "diagnostics"
404389 Just pathB <- pure $ uriToFilePath uriB
405390 uriB <- pure $
406391 let (drive, suffix) = splitDrive pathB
407− in filePathToUri (joinDrive (lower drive) suffix)
392+ in filePathToUri (joinDrive (map toLower drive ) suffix)
408393 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409394 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410395 uriA <- getDocUri "A/A.hs"
411396 Just pathA <- pure $ uriToFilePath uriA
412397 uriA <- pure $
413398 let (drive, suffix) = splitDrive pathA
414− in filePathToUri (joinDrive (lower drive) suffix)
399+ in filePathToUri (joinDrive (map toLower drive ) suffix)
415400 let itemA = TextDocumentItem uriA "haskell" 0 aContent
416401 let a = TextDocumentIdentifier uriA
417402 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418− diagsNot <- skipManyTill anyMessage diagnostic
403+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
419404 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420405 -- Check that if we put a lower-case drive in for A.A
421406 -- the diagnostics for A.B will also be lower-case.
@@ -424,38 +409,6 @@ diagnosticTests = testGroup "diagnostics"
424409 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425410 assertFailure ("Expected redundant import but got " <> T.unpack msg)
426411 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
459412 ]
460413
461414codeActionTests :: TestTree
@@ -481,26 +434,26 @@ codeLensesTests = testGroup "code lenses"
481434watchedFilesTests :: TestTree
482435watchedFilesTests = testGroup "watched files"
483436 [ 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
437+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
438+ _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
439+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
440+
441+ -- Expect 6 subscriptions (A does not get any because it's VFS):
442+ -- - /path-to-workspace/B.hs
443+ -- - /path-to-workspace/B.lhs
444+ -- - B.hs
445+ -- - B.lhs
446+ -- - src/B.hs
447+ -- - src/B.lhs
448+ liftIO $ length watchedFileRegs @?= 6
494449
495450 , 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
451+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
452+ _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
453+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
499454
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
455+ -- Expect 4 subscriptions:
456+ liftIO $ length watchedFileRegs @?= 4
504457
505458 -- TODO add a test for didChangeWorkspaceFolder
506459 ]
@@ -513,7 +466,7 @@ renameActionTests = testGroup "rename actions"
513466 , "foo :: Int -> Int"
514467 , "foo argName = argNme"
515468 ]
516− doc <- createDoc "Testing.hs" "haskell" content
469+ doc <- openDoc' "Testing.hs" "haskell" content
517470 _ <- waitForDiagnostics
518471 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
519472 executeCodeAction action
@@ -531,7 +484,7 @@ renameActionTests = testGroup "rename actions"
531484 , "foo :: Maybe a -> [a]"
532485 , "foo = maybToList"
533486 ]
534− doc <- createDoc "Testing.hs" "haskell" content
487+ doc <- openDoc' "Testing.hs" "haskell" content
535488 _ <- waitForDiagnostics
536489 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
537490 executeCodeAction action
@@ -549,7 +502,7 @@ renameActionTests = testGroup "rename actions"
549502 , "foo :: Char -> Char -> Char -> Char"
550503 , "foo argument1 argument2 argument3 = argumentX"
551504 ]
552− doc <- createDoc "Testing.hs" "haskell" content
505+ doc <- openDoc' "Testing.hs" "haskell" content
553506 _ <- waitForDiagnostics
554507 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
555508 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -561,7 +514,7 @@ renameActionTests = testGroup "rename actions"
561514 , "monus x y = max 0 (x - y)"
562515 , "foo x y = x `monnus` y"
563516 ]
564− doc <- createDoc "Testing.hs" "haskell" content
517+ doc <- openDoc' "Testing.hs" "haskell" content
565518 _ <- waitForDiagnostics
566519 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567520 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -584,7 +537,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
584537 , "func :: _"
585538 , "func x = x"
586539 ]
587− doc <- createDoc "Testing.hs" "haskell" content
540+ doc <- openDoc' "Testing.hs" "haskell" content
588541 _ <- waitForDiagnostics
589542 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590543 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -604,7 +557,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
604557 , "func :: _"
605558 , "func x y = x + y"
606559 ]
607− doc <- createDoc "Testing.hs" "haskell" content
560+ doc <- openDoc' "Testing.hs" "haskell" content
608561 _ <- waitForDiagnostics
609562 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610563 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -627,7 +580,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
627580 , " y = x * 2"
628581 , " in y"
629582 ]
630− doc <- createDoc "Testing.hs" "haskell" content
583+ doc <- openDoc' "Testing.hs" "haskell" content
631584 _ <- waitForDiagnostics
632585 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633586 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -652,7 +605,7 @@ removeImportTests = testGroup "remove import actions"
652605 let contentA = T.unlines
653606 [ "module ModuleA where"
654607 ]
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
608+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
656609 let contentB = T.unlines
657610 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658611 , "module ModuleB where"
@@ -660,7 +613,7 @@ removeImportTests = testGroup "remove import actions"
660613 , "stuffB :: Integer"
661614 , "stuffB = 123"
662615 ]
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
616+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
664617 _ <- waitForDiagnostics
665618 [CACodeAction action@CodeAction { _title = actionTitle }]
666619 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -678,7 +631,7 @@ removeImportTests = testGroup "remove import actions"
678631 let contentA = T.unlines
679632 [ "module ModuleA where"
680633 ]
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
634+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
682635 let contentB = T.unlines
683636 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684637 , "module ModuleB where"
@@ -686,7 +639,7 @@ removeImportTests = testGroup "remove import actions"
686639 , "stuffB :: Integer"
687640 , "stuffB = 123"
688641 ]
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
642+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
690643 _ <- waitForDiagnostics
691644 [CACodeAction action@CodeAction { _title = actionTitle }]
692645 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -708,14 +661,14 @@ removeImportTests = testGroup "remove import actions"
708661 , "stuffB = 123"
709662 , "stuffC = ()"
710663 ]
711− _docA <- createDoc "ModuleA.hs" "haskell" contentA
664+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
712665 let contentB = T.unlines
713666 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714667 , "module ModuleB where"
715668 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716669 , "main = print stuffB"
717670 ]
718− docB <- createDoc "ModuleB.hs" "haskell" contentB
671+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
719672 _ <- waitForDiagnostics
720673 [CACodeAction action@CodeAction { _title = actionTitle }]
721674 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -737,18 +690,22 @@ removeImportTests = testGroup "remove import actions"
737690 , "stuffB :: Integer"
738691 , "stuffB = 123"
739692 ]
740− _docA <- createDoc "ModuleA.hs" "haskell" contentA
693+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
741694 let contentB = T.unlines
742695 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743696 , "module ModuleB where"
744697 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745698 , "main = print A.stuffB"
746699 ]
747− docB <- createDoc "ModuleB.hs" "haskell" contentB
700+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
748701 _ <- waitForDiagnostics
749702 [CACodeAction action@CodeAction { _title = actionTitle }]
750703 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
704+#if MIN_GHC_API_VERSION(8,6,0)
751705 liftIO $ "Remove !!, <?> from import" @=? actionTitle
706+#else
707+ liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
708+#endif
752709 executeCodeAction action
753710 contentAfterAction <- documentContents docB
754711 let expectedContentAfterAction = T.unlines
@@ -765,14 +722,14 @@ removeImportTests = testGroup "remove import actions"
765722 , "stuffB :: Integer"
766723 , "stuffB = 123"
767724 ]
768− _docA <- createDoc "ModuleA.hs" "haskell" contentA
725+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
769726 let contentB = T.unlines
770727 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771728 , "module ModuleB where"
772729 , "import ModuleA (A(..), stuffB)"
773730 , "main = print stuffB"
774731 ]
775− docB <- createDoc "ModuleB.hs" "haskell" contentB
732+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
776733 _ <- waitForDiagnostics
777734 [CACodeAction action@CodeAction { _title = actionTitle }]
778735 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -792,14 +749,14 @@ removeImportTests = testGroup "remove import actions"
792749 , "data D = A | B"
793750 , "data E = F"
794751 ]
795− _docA <- createDoc "ModuleA.hs" "haskell" contentA
752+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
796753 let contentB = T.unlines
797754 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798755 , "module ModuleB where"
799756 , "import ModuleA (D(A,B), E(F))"
800757 , "main = B"
801758 ]
802− docB <- createDoc "ModuleB.hs" "haskell" contentB
759+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
803760 _ <- waitForDiagnostics
804761 [CACodeAction action@CodeAction { _title = actionTitle }]
805762 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -940,8 +897,8 @@ extendImportTests = testGroup "extend import actions"
940897 ]
941898 where
942899 template contentA contentB range expectedAction expectedContentB = do
943− _docA <- createDoc "ModuleA.hs" "haskell" contentA
944− docB <- createDoc "ModuleB.hs" "haskell" contentB
900+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
901+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
945902 _ <- waitForDiagnostics
946903 CACodeAction action@CodeAction { _title = actionTitle } : _
947904 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -981,8 +938,6 @@ suggestImportTests = testGroup "suggest import actions"
981938 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982939 , test True [] "f = pack" [] "import Data.Text (pack)"
983940 , 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 ((&))"
986941 ]
987942 ]
988943 where
@@ -991,20 +946,19 @@ suggestImportTests = testGroup "suggest import actions"
991946 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992947 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993948 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994− doc <- createDoc "Test.hs" "haskell" before
949+ doc <- openDoc' "Test.hs" "haskell" before
995950 _diags <- waitForDiagnostics
996951 let defLine = length imps + 1
997952 range = Range (Position defLine 0) (Position defLine maxBound)
998953 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−
954+ case wanted of
955+ False ->
956+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
957+ True -> do
958+ action <- liftIO $ pickActionWithTitle newImp actions
959+ executeCodeAction action
960+ contentAfterAction <- documentContents doc
961+ liftIO $ after @=? contentAfterAction
1008962
1009963addExtensionTests :: TestTree
1010964addExtensionTests = testGroup "add language extension actions"
@@ -1051,7 +1005,7 @@ addExtensionTests = testGroup "add language extension actions"
10511005 ]
10521006 where
10531007 template initialContent range expectedAction expectedContents = do
1054− doc <- createDoc "Module.hs" "haskell" initialContent
1008+ doc <- openDoc' "Module.hs" "haskell" initialContent
10551009 _ <- waitForDiagnostics
10561010 CACodeAction action@CodeAction { _title = actionTitle } : _
10571011 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1074,7 +1028,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10741028 [""
10751029 ,"someOtherCode = ()"
10761030 ]
1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1031+ docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10781032 _ <- waitForDiagnostics
10791033 CACodeAction action@CodeAction { _title = actionTitle } : _
10801034 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1098,7 +1052,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10981052 [""
10991053 ,"someOtherCode = ()"
11001054 ]
1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1055+ docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
11021056 _ <- waitForDiagnostics
11031057 CACodeAction action@CodeAction { _title = actionTitle } : _
11041058 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1137,8 +1091,8 @@ fixConstructorImportTests = testGroup "fix import actions"
11371091 ]
11381092 where
11391093 template contentA contentB range expectedAction expectedContentB = do
1140− _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141− docB <- createDoc "ModuleB.hs" "haskell" contentB
1094+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1095+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
11421096 _diags <- waitForDiagnostics
11431097 CACodeAction action@CodeAction { _title = actionTitle } : _
11441098 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1157,7 +1111,7 @@ importRenameActionTests = testGroup "import rename actions"
11571111 [ "module Testing where"
11581112 , "import Data.Mape"
11591113 ]
1160− doc <- createDoc "Testing.hs" "haskell" content
1114+ doc <- openDoc' "Testing.hs" "haskell" content
11611115 _ <- waitForDiagnostics
11621116 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
11631117 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1194,7 +1148,7 @@ fillTypedHoleTests = let
11941148 newA newB newC = testSession (T.unpack actionTitle) $ do
11951149 let originalCode = sourceCode oldA oldB oldC
11961150 let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
1151+ doc <- openDoc' "Testing.hs" "haskell" originalCode
11981152 _ <- waitForDiagnostics
11991153 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
12001154 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1242,7 +1196,7 @@ addSigActionTests = let
12421196 def >:: sig = testSession (T.unpack def) $ do
12431197 let originalCode = before def
12441198 let expectedCode = after' def sig
1245− doc <- createDoc "Sigs.hs" "haskell" originalCode
1199+ doc <- openDoc' "Sigs.hs" "haskell" originalCode
12461200 _ <- waitForDiagnostics
12471201 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
12481202 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1274,7 +1228,7 @@ addSigLensesTests = let
12741228 sigSession withMissing def sig = testSession (T.unpack def) $ do
12751229 let originalCode = before withMissing def
12761230 let expectedCode = after' withMissing def sig
1277− doc <- createDoc "Sigs.hs" "haskell" originalCode
1231+ doc <- openDoc' "Sigs.hs" "haskell" originalCode
12781232 [CodeLens {_command = Just c}] <- getCodeLenses doc
12791233 executeCommand c
12801234 modifiedCode <- getDocumentEdit doc
@@ -1296,39 +1250,33 @@ addSigLensesTests = let
12961250 ]
12971251 ]
12981252
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−
13201253findDefinitionAndHoverTests :: TestTree
13211254findDefinitionAndHoverTests = let
13221255
1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324− doc <- openTestDataDoc (dir </> sourceFilePath)
1256+ tst (get, check) pos targetRange title = testSession title $ do
1257+ doc <- openTestDataDoc sourceFilePath
13251258 found <- get doc pos
13261259 check found targetRange
13271260
1261+ checkDefs :: [Location] -> [Expect] -> Session ()
1262+ checkDefs defs expectations = traverse_ check expectations where
1263+
1264+ check (ExpectRange expectedRange) = do
1265+ assertNDefinitionsFound 1 defs
1266+ assertRangeCorrect (head defs) expectedRange
1267+ check ExpectNoDefinitions = do
1268+ assertNDefinitionsFound 0 defs
1269+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1270+ check _ = pure () -- all other expectations not relevant to getDefinition
1271+
1272+ assertNDefinitionsFound :: Int -> [a] -> Session ()
1273+ assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
13281274
1275+ assertRangeCorrect Location{_range = foundRange} expectedRange =
1276+ liftIO $ expectedRange @=? foundRange
13291277
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
1278+ checkHover :: Maybe Hover -> [Expect] -> Session ()
1279+ checkHover hover expectations = traverse_ check expectations where
13321280
13331281 check expected =
13341282 case hover of
@@ -1371,12 +1319,9 @@ findDefinitionAndHoverTests = let
13711319
13721320 mkFindTests tests = testGroup "get"
13731321 [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
1375− , checkFileCompiles sourceFilePath ]
1322+ , testGroup "hover" $ mapMaybe snd tests ]
13761323
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
1378−
1379− testM runDef runHover look expect title =
1324+ test runDef runHover look expect title =
13801325 ( runDef $ tst def look expect title
13811326 , runHover $ tst hover look expect title ) where
13821327 def = (getDefinitions, checkDefs)
@@ -1384,100 +1329,87 @@ findDefinitionAndHoverTests = let
13841329 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
13851330
13861331 -- 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"]]
1332+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1333+ fffL8 = Position 8 4 ;
1334+ fffL14 = Position 14 7 ;
1335+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1336+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1337+ dcL12 = Position 12 11 ;
1338+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1339+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1340+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1341+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1342+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1343+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1344+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1345+ xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1346+ clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1347+ clL25 = Position 25 9
1348+ eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1349+ dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1350+ dnbL30 = Position 30 23
1351+ lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1352+ lclL33 = Position 33 22
1353+ mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1354+ mclL37 = Position 37 1
1355+ spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1356+ docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
14121357 ; 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]
1358+ eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1359+ intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1360+ tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1361+ intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1362+ chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1363+ txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1364+ lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1365+ outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1366+ innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
14241367 in
14251368 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)"
1369+ -- def hover look expect
1370+ [ test yes yes fffL4 fff "field in record definition"
1371+ , test broken broken fffL8 fff "field in record construction #71"
1372+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1373+ , test yes yes aaaL14 aaa "top-level name" -- 120
1374+ , test yes yes dcL7 tcDC "data constructor record #247"
1375+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1376+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1377+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1378+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1379+ , test yes yes vvL16 vv "plain parameter" -- 120
1380+ , test yes yes aL18 apmp "pattern match name" -- 120
1381+ , test yes yes opL16 op "top-level operator" -- 120, 123
1382+ , test yes yes opL18 opp "parameter operator" -- 120
1383+ , test yes yes b'L19 bp "name in backticks" -- 120
1384+ , test yes yes clL23 cls "class in instance declaration #250"
1385+ , test yes yes clL25 cls "class in signature #250" -- 147
1386+ , test broken yes eclL15 ecls "external class in signature #249,250"
1387+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1388+ , test yes yes dnbL30 dnb "do-notation lookup"
1389+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1390+ , test yes yes lclL33 lcb "listcomp lookup"
1391+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1392+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1393+ , test yes yes spaceL37 space "top-level fn on space #315"
1394+ , test no broken docL41 doc "documentation #7"
1395+ , test no yes eitL40 kindE "kind of Either #273"
1396+ , test no yes intL40 kindI "kind of Int #273"
1397+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1398+ , test no yes intL41 litI "literal Int in hover info #274"
1399+ , test no yes chrL36 litC "literal Char in hover info #274"
1400+ , test no yes txtL8 litT "literal Text in hover info #274"
1401+ , test no yes lstL43 litL "literal List in hover info #274"
1402+ , test no yes docL41 constr "type constraint in hover info #283"
1403+ , test broken broken outL45 outSig "top-level signature #310"
1404+ , test broken broken innL48 innSig "inner signature #310"
14641405 ]
14651406 where yes, broken :: (TestTree -> Maybe TestTree)
14661407 yes = Just -- test should run and pass
14671408 broken = Just . (`xfail` "known broken")
14681409 no = const Nothing -- don't run this test at all
14691410
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−
14781411pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
1412+pluginTests = testSessionWait "plugins" $ do
14811413 let content =
14821414 T.unlines
14831415 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1491,7 +1423,7 @@ pluginTests = (`xfail8101` "known broken (#556)")
14911423 , "foo :: Int -> Int -> Int"
14921424 , "foo a b = a + c"
14931425 ]
1494− _ <- createDoc "Testing.hs" "haskell" content
1426+ _ <- openDoc' "Testing.hs" "haskell" content
14951427 expectDiagnostics
14961428 [ ( "Testing.hs",
14971429 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1518,7 +1450,7 @@ cppTests =
15181450 run $ expectError content (2, 1)
15191451 )
15201452 , testSessionWait "cpp-ghcide" $ do
1521− _ <- createDoc "A.hs" "haskell" $ T.unlines
1453+ _ <- openDoc' "A.hs" "haskell" $ T.unlines
15221454 ["{-# LANGUAGE CPP #-}"
15231455 ,"main ="
15241456 ,"#ifdef __GHCIDE__"
@@ -1532,7 +1464,7 @@ cppTests =
15321464 where
15331465 expectError :: T.Text -> Cursor -> Session ()
15341466 expectError content cursor = do
1535− _ <- createDoc "Testing.hs" "haskell" content
1467+ _ <- openDoc' "Testing.hs" "haskell" content
15361468 expectDiagnostics
15371469 [ ( "Testing.hs",
15381470 [(DsError, cursor, "error: unterminated")]
@@ -1548,7 +1480,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do
15481480 , "module Testing where"
15491481 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
15501482 ]
1551− _ <- createDoc "Testing.hs" "haskell" content
1483+ _ <- openDoc' "Testing.hs" "haskell" content
15521484 expectDiagnostics
15531485 [ ( "Testing.hs",
15541486 [(DsError, (2, 8), "Variable not in scope: z")]
@@ -1581,8 +1513,8 @@ safeTests =
15811513 ,"safeId = trustWorthyId"
15821514 ]
15831515
1584− _ <- createDoc "A.hs" "haskell" sourceA
1585− _ <- createDoc "B.hs" "haskell" sourceB
1516+ _ <- openDoc' "A.hs" "haskell" sourceA
1517+ _ <- openDoc' "B.hs" "haskell" sourceB
15861518 expectNoMoreDiagnostics 1 ]
15871519
15881520thTests :: TestTree
@@ -1610,8 +1542,8 @@ thTests =
16101542 "b :: Integer",
16111543 "b = $(litE $ IntegerL $ a) + n"
16121544 ]
1613− _ <- createDoc "A.hs" "haskell" sourceA
1614− _ <- createDoc "B.hs" "haskell" sourceB
1545+ _ <- openDoc' "A.hs" "haskell" sourceA
1546+ _ <- openDoc' "B.hs" "haskell" sourceB
16151547 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
16161548 , testSessionWait "newtype-closure" $ do
16171549 let sourceA =
@@ -1631,8 +1563,8 @@ thTests =
16311563 ,"import A"
16321564 ,"b :: Int"
16331565 ,"b = $( a )" ]
1634− _ <- createDoc "A.hs" "haskell" sourceA
1635− _ <- createDoc "B.hs" "haskell" sourceB
1566+ _ <- openDoc' "A.hs" "haskell" sourceA
1567+ _ <- openDoc' "B.hs" "haskell" sourceB
16361568 return ()
16371569 ]
16381570
@@ -1641,7 +1573,7 @@ completionTests
16411573 = testGroup "completion"
16421574 [ testSessionWait "variable" $ do
16431575 let source = T.unlines ["module A where", "f = hea"]
1644− docId <- createDoc "A.hs" "haskell" source
1576+ docId <- openDoc' "A.hs" "haskell" source
16451577 compls <- getCompletions docId (Position 1 7)
16461578 liftIO $ map dropDocs compls @?=
16471579 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1653,7 +1585,7 @@ completionTests
16531585 ]
16541586 , testSessionWait "constructor" $ do
16551587 let source = T.unlines ["module A where", "f = Tru"]
1656− docId <- createDoc "A.hs" "haskell" source
1588+ docId <- openDoc' "A.hs" "haskell" source
16571589 compls <- getCompletions docId (Position 1 7)
16581590 liftIO $ map dropDocs compls @?=
16591591 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1665,7 +1597,7 @@ completionTests
16651597 ]
16661598 , testSessionWait "type" $ do
16671599 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668− docId <- createDoc "A.hs" "haskell" source
1600+ docId <- openDoc' "A.hs" "haskell" source
16691601 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
16701602 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
16711603 compls <- getCompletions docId (Position 2 7)
@@ -1682,7 +1614,7 @@ completionTests
16821614 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
16831615 , testSessionWait "qualified" $ do
16841616 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685− docId <- createDoc "A.hs" "haskell" source
1617+ docId <- openDoc' "A.hs" "haskell" source
16861618 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
16871619 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
16881620 compls <- getCompletions docId (Position 2 15)
@@ -1696,7 +1628,7 @@ completionTests
16961628 ]
16971629 , testSessionWait "keyword" $ do
16981630 let source = T.unlines ["module A where", "f = newty"]
1699− docId <- createDoc "A.hs" "haskell" source
1631+ docId <- openDoc' "A.hs" "haskell" source
17001632 compls <- getCompletions docId (Position 1 9)
17011633 liftIO $ compls @?= [keywordItem "newtype"]
17021634 , testSessionWait "type context" $ do
@@ -1705,7 +1637,7 @@ completionTests
17051637 , "module A () where"
17061638 , "f = f"
17071639 ]
1708− docId <- createDoc "A.hs" "haskell" source
1640+ docId <- openDoc' "A.hs" "haskell" source
17091641 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
17101642 changeDoc docId
17111643 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
@@ -1773,7 +1705,7 @@ outlineTests = testGroup
17731705 "outline"
17741706 [ testSessionWait "type class" $ do
17751707 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776− docId <- createDoc "A.hs" "haskell" source
1708+ docId <- openDoc' "A.hs" "haskell" source
17771709 symbols <- getDocumentSymbols docId
17781710 liftIO $ symbols @?= Left
17791711 [ moduleSymbol
@@ -1786,7 +1718,7 @@ outlineTests = testGroup
17861718 ]
17871719 , testSessionWait "type class instance " $ do
17881720 let source = T.unlines ["class A a where", "instance A () where"]
1789− docId <- createDoc "A.hs" "haskell" source
1721+ docId <- openDoc' "A.hs" "haskell" source
17901722 symbols <- getDocumentSymbols docId
17911723 liftIO $ symbols @?= Left
17921724 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1794,7 +1726,7 @@ outlineTests = testGroup
17941726 ]
17951727 , testSessionWait "type family" $ do
17961728 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797− docId <- createDoc "A.hs" "haskell" source
1729+ docId <- openDoc' "A.hs" "haskell" source
17981730 symbols <- getDocumentSymbols docId
17991731 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
18001732 , testSessionWait "type family instance " $ do
@@ -1803,7 +1735,7 @@ outlineTests = testGroup
18031735 , "type family A a"
18041736 , "type instance A () = ()"
18051737 ]
1806− docId <- createDoc "A.hs" "haskell" source
1738+ docId <- openDoc' "A.hs" "haskell" source
18071739 symbols <- getDocumentSymbols docId
18081740 liftIO $ symbols @?= Left
18091741 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1811,7 +1743,7 @@ outlineTests = testGroup
18111743 ]
18121744 , testSessionWait "data family" $ do
18131745 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814− docId <- createDoc "A.hs" "haskell" source
1746+ docId <- openDoc' "A.hs" "haskell" source
18151747 symbols <- getDocumentSymbols docId
18161748 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
18171749 , testSessionWait "data family instance " $ do
@@ -1820,7 +1752,7 @@ outlineTests = testGroup
18201752 , "data family A a"
18211753 , "data instance A () = A ()"
18221754 ]
1823− docId <- createDoc "A.hs" "haskell" source
1755+ docId <- openDoc' "A.hs" "haskell" source
18241756 symbols <- getDocumentSymbols docId
18251757 liftIO $ symbols @?= Left
18261758 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1828,36 +1760,36 @@ outlineTests = testGroup
18281760 ]
18291761 , testSessionWait "constant" $ do
18301762 let source = T.unlines ["a = ()"]
1831− docId <- createDoc "A.hs" "haskell" source
1763+ docId <- openDoc' "A.hs" "haskell" source
18321764 symbols <- getDocumentSymbols docId
18331765 liftIO $ symbols @?= Left
18341766 [docSymbol "a" SkFunction (R 0 0 0 6)]
18351767 , testSessionWait "pattern" $ do
18361768 let source = T.unlines ["Just foo = Just 21"]
1837− docId <- createDoc "A.hs" "haskell" source
1769+ docId <- openDoc' "A.hs" "haskell" source
18381770 symbols <- getDocumentSymbols docId
18391771 liftIO $ symbols @?= Left
18401772 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
18411773 , testSessionWait "pattern with type signature" $ do
18421774 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843− docId <- createDoc "A.hs" "haskell" source
1775+ docId <- openDoc' "A.hs" "haskell" source
18441776 symbols <- getDocumentSymbols docId
18451777 liftIO $ symbols @?= Left
18461778 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
18471779 , testSessionWait "function" $ do
18481780 let source = T.unlines ["a x = ()"]
1849− docId <- createDoc "A.hs" "haskell" source
1781+ docId <- openDoc' "A.hs" "haskell" source
18501782 symbols <- getDocumentSymbols docId
18511783 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
18521784 , testSessionWait "type synonym" $ do
18531785 let source = T.unlines ["type A = Bool"]
1854− docId <- createDoc "A.hs" "haskell" source
1786+ docId <- openDoc' "A.hs" "haskell" source
18551787 symbols <- getDocumentSymbols docId
18561788 liftIO $ symbols @?= Left
18571789 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
18581790 , testSessionWait "datatype" $ do
18591791 let source = T.unlines ["data A = C"]
1860− docId <- createDoc "A.hs" "haskell" source
1792+ docId <- openDoc' "A.hs" "haskell" source
18611793 symbols <- getDocumentSymbols docId
18621794 liftIO $ symbols @?= Left
18631795 [ docSymbolWithChildren "A"
@@ -1865,21 +1797,9 @@ outlineTests = testGroup
18651797 (R 0 0 0 10)
18661798 [docSymbol "C" SkConstructor (R 0 9 0 10)]
18671799 ]
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− ]
18801800 , testSessionWait "import" $ do
18811801 let source = T.unlines ["import Data.Maybe"]
1882− docId <- createDoc "A.hs" "haskell" source
1802+ docId <- openDoc' "A.hs" "haskell" source
18831803 symbols <- getDocumentSymbols docId
18841804 liftIO $ symbols @?= Left
18851805 [docSymbolWithChildren "imports"
@@ -1890,7 +1810,7 @@ outlineTests = testGroup
18901810 ]
18911811 , testSessionWait "multiple import" $ do
18921812 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893− docId <- createDoc "A.hs" "haskell" source
1813+ docId <- openDoc' "A.hs" "haskell" source
18941814 symbols <- getDocumentSymbols docId
18951815 liftIO $ symbols @?= Left
18961816 [docSymbolWithChildren "imports"
@@ -1905,7 +1825,7 @@ outlineTests = testGroup
19051825 [ "{-# language ForeignFunctionInterface #-}"
19061826 , "foreign import ccall \"a\" a :: Int"
19071827 ]
1908− docId <- createDoc "A.hs" "haskell" source
1828+ docId <- openDoc' "A.hs" "haskell" source
19091829 symbols <- getDocumentSymbols docId
19101830 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
19111831 , testSessionWait "foreign export" $ do
@@ -1913,7 +1833,7 @@ outlineTests = testGroup
19131833 [ "{-# language ForeignFunctionInterface #-}"
19141834 , "foreign export ccall odd :: Int -> Bool"
19151835 ]
1916− docId <- createDoc "A.hs" "haskell" source
1836+ docId <- openDoc' "A.hs" "haskell" source
19171837 symbols <- getDocumentSymbols docId
19181838 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
19191839 ]
@@ -1926,8 +1846,6 @@ outlineTests = testGroup
19261846 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
19271847 docSymbolWithChildren name kind loc cc =
19281848 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)
19311849 moduleSymbol name loc cc = DocumentSymbol name
19321850 Nothing
19331851 SkFile
@@ -1949,16 +1867,8 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
19491867xfail :: TestTree -> String -> TestTree
19501868xfail = flip expectFailBecause
19511869
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−
19591870data Expect
19601871 = ExpectRange Range -- Both gotoDef and hover should report this range
1961− | ExpectLocation Location
19621872-- | ExpectDefRange Range -- Only gotoDef should report this range
19631873 | ExpectHoverRange Range -- Only hover should report this range
19641874 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1971,9 +1881,6 @@ data Expect
19711881mkR :: Int -> Int -> Int -> Int -> Expect
19721882mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
19731883
1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976−
19771884haddockTests :: TestTree
19781885haddockTests
19791886 = testGroup "haddock"
@@ -2033,7 +1940,6 @@ cradleTests :: TestTree
20331940cradleTests = testGroup "cradle"
20341941 [testGroup "dependencies" [sessionDepsArePickedUp]
20351942 ,testGroup "loading" [loadCradleOnlyonce]
2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
20371943 ]
20381944
20391945loadCradleOnlyonce :: TestTree
@@ -2048,53 +1954,17 @@ loadCradleOnlyonce = testGroup "load cradle only once"
20481954 test dir
20491955 implicit dir = test dir
20501956 test _dir = do
2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
1957+ doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
20521958 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20531959 liftIO $ length msgs @?= 1
20541960 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
20551961 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20561962 liftIO $ length msgs @?= 0
2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
1963+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"
20581964 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
20591965 liftIO $ length msgs @?= 0
20601966
20611967
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−
20981968cradleLoadedMessage :: Session FromServerMessage
20991969cradleLoadedMessage = satisfy $ \case
21001970 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -2103,56 +1973,6 @@ cradleLoadedMessage = satisfy $ \case
21031973cradleLoadedMethod :: T.Text
21041974cradleLoadedMethod = "ghcide/cradle/loaded"
21051975
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−
21561976sessionDepsArePickedUp :: TestTree
21571977sessionDepsArePickedUp = testSession'
21581978 "session-deps-are-picked-up"
@@ -2162,7 +1982,7 @@ sessionDepsArePickedUp = testSession'
21621982 (dir </> "hie.yaml")
21631983 "cradle: {direct: {arguments: []}}"
21641984 -- Open without OverloadedStrings and expect an error.
2165− doc <- createDoc "Foo.hs" "haskell" fooContent
1985+ doc <- openDoc' "Foo.hs" "haskell" fooContent
21661986 expectDiagnostics
21671987 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
21681988 -- Update hie.yaml to enable OverloadedStrings.
@@ -2197,9 +2017,6 @@ sessionDepsArePickedUp = testSession'
21972017testSession :: String -> Session () -> TestTree
21982018testSession name = testCase name . run
21992019
2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202−
22032020testSession' :: String -> (FilePath -> Session ()) -> TestTree
22042021testSession' name = testCase name . run'
22052022
@@ -2234,19 +2051,6 @@ mkRange a b c d = Range (Position a b) (Position c d)
22342051run :: Session a -> IO a
22352052run s = withTempDir $ \dir -> runInDir dir s
22362053
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−
22502054run' :: (FilePath -> Session a) -> IO a
22512055run' s = withTempDir $ \dir -> runInDir dir (s dir)
22522056
@@ -2258,7 +2062,6 @@ runInDir dir s = do
22582062 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
22592063 createDirectoryIfMissing True $ dir ++ "/Data"
22602064
2261−
22622065 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
22632066 -- HIE calls getXgdDirectory which assumes that HOME is set.
22642067 -- Only sets HOME if it wasn't already set.
@@ -2276,7 +2079,7 @@ runInDir dir s = do
22762079openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
22772080openTestDataDoc path = do
22782081 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
2082+ openDoc' path "haskell" source
22802083
22812084findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
22822085findCodeActions doc range expectedTitles = do
@@ -2317,6 +2120,20 @@ unitTests = do
23172120 uriToFilePath' uri @?= Just ""
23182121 ]
23192122
2123+-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2124+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2125+openDoc' fp name contents = do
2126+ res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2127+ -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2128+ sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2129+ return res
2130+
2131+-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2132+openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2133+-- At the moment this is just LSPTest.openDoc' but it may change in the future
2134+-- when/if lsp-test implements WatchedFiles
2135+openDoc'' = LSPTest.openDoc'
2136+
23202137positionMappingTests :: TestTree
23212138positionMappingTests =
23222139 testGroup "position mapping"
@@ -2486,11 +2303,11 @@ nthLine i r
24862303 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
24872304 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
24882305
2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490−getWatchedFilesSubscriptionsUntil = do
2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2306+getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
2307+getWatchedFilesSubscriptionsUntilProgressEnd = do
2308+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
24922309 return
24932310 [ args
2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2311+ | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
24952312 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
24962313 ]