@@ -10,7 +10,8 @@
10module Main (main) where
10module Main (main) where
12import Control.Applicative.Combinators
12import Control.Applicative.Combinators
13−import Control.Exception (catch)
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
14import Control.Monad
15import Control.Monad
15import Control.Monad.IO.Class (liftIO)
16import Control.Monad.IO.Class (liftIO)
16import Data.Aeson (FromJSON, Value)
17import Data.Aeson (FromJSON, Value)
@@ -27,14 +28,14 @@ import Development.IDE.Test
27import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
28import Development.IDE.Types.Location
29import Development.IDE.Types.Location
29import Development.Shake (getDirectoryFilesIO)
30import Development.Shake (getDirectoryFilesIO)
30−import qualified Language.Haskell.LSP.Test as LSPTest
31+import Language.Haskell.LSP.Test
31−import Language.Haskell.LSP.Test hiding (openDoc')
32import Language.Haskell.LSP.Messages
32import Language.Haskell.LSP.Messages
33import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
34import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
35import Language.Haskell.LSP.VFS (applyChange)
36import Language.Haskell.LSP.VFS (applyChange)
36import Network.URI
37import Network.URI
37−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
38import System.FilePath
39import System.FilePath
39import System.IO.Extra
40import System.IO.Extra
40import System.Directory
41import System.Directory
@@ -48,31 +49,35 @@ import Test.Tasty.QuickCheck
48import Data.Maybe
49import Data.Maybe
50main :: IO ()
51main :: IO ()
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
51−main = defaultMainWithRerun $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
52− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
53− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
54− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
55− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
56− closeDoc doc
60+ closeDoc doc
57− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
58− , initializeResponseTests
62+ , initializeResponseTests
59− , completionTests
63+ , completionTests
60− , cppTests
64+ , cppTests
61− , diagnosticTests
65+ , diagnosticTests
62− , codeActionTests
66+ , codeActionTests
63− , codeLensesTests
67+ , codeLensesTests
64− , outlineTests
68+ , outlineTests
65− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
66− , pluginTests
70+ , pluginTests
67− , preprocessorTests
71+ , preprocessorTests
68− , thTests
72+ , thTests
69− , safeTests
73+ , safeTests
70− , unitTests
74+ , unitTests
71− , haddockTests
75+ , haddockTests
72− , positionMappingTests
76+ , positionMappingTests
73− , watchedFilesTests
77+ , watchedFilesTests
74− , cradleTests
78+ , cradleTests
77initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
78initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -133,7 +138,7 @@ initializeResponseTests = withResource acquire release tests where
135 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
136− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
137 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
139 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -147,7 +152,7 @@ diagnosticTests :: TestTree
147diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
148 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
149 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
150− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
151 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
152 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
153 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -158,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"
158 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
159 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
160 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
161− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
162 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
163 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
164 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
@@ -176,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
176 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
177 , "bar a b = cd + b"
182 , "bar a b = cd + b"
179− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
180 expectDiagnostics
185 expectDiagnostics
181 [ ( "Testing.hs"
186 [ ( "Testing.hs"
182 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -190,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
190 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
191 , "foo a b = a + b"
196 , "foo a b = a + b"
193− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
194 expectDiagnostics
199 expectDiagnostics
195 [ ( "Testing.hs"
200 [ ( "Testing.hs"
196 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -202,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
202 , "foo :: Int -> String"
207 , "foo :: Int -> String"
203 , "foo a = _ a"
208 , "foo a = _ a"
205− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
206 expectDiagnostics
211 expectDiagnostics
207 [ ( "Testing.hs"
212 [ ( "Testing.hs"
208 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -224,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
224 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
225 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
226 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
227− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
228− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
229 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
231 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
232 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
233 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
234− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
237 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
238 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
239− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
240 let contentB = T.unlines
244 let contentB = T.unlines
241 [ "module ModuleB where"
245 [ "module ModuleB where"
242 , "import ModuleA"
246 , "import ModuleA"
244− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
245 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
246 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
247 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -254,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
254 [ "module ModuleB where"
258 [ "module ModuleB where"
255 , "import ModuleA"
259 , "import ModuleA"
257− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
258 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
259 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
260− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
261 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
262 , testSessionWait "add missing module (non workspace)" $ do
266 , testSessionWait "add missing module (non workspace)" $ do
263 let contentB = T.unlines
267 let contentB = T.unlines
264 [ "module ModuleB where"
268 [ "module ModuleB where"
265 , "import ModuleA"
269 , "import ModuleA"
267− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
268 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
269 let contentA = T.unlines [ "module ModuleA where" ]
273 let contentA = T.unlines [ "module ModuleA where" ]
270− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
271 expectDiagnostics [("/tmp/ModuleB.hs", [])]
275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
272 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
273 let contentA = T.unlines
277 let contentA = T.unlines
@@ -278,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
278 [ "module ModuleB where"
282 [ "module ModuleB where"
279 , "import ModuleA"
283 , "import ModuleA"
281− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
282− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
283 expectDiagnostics
287 expectDiagnostics
284 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
285 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -300,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
300 let contentBboot = T.unlines
304 let contentBboot = T.unlines
301 [ "module ModuleB where"
305 [ "module ModuleB where"
303− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
304− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
305− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
306 expectDiagnostics []
310 expectDiagnostics []
307 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
308 let contentB = T.unlines
312 let contentB = T.unlines
@@ -324,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
324 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
325 , "y = x"
329 , "y = x"
327− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
328− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
329− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
330− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
331 expectDiagnostics []
335 expectDiagnostics []
332 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
333 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -336,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
336 , "module ModuleB where"
340 , "module ModuleB where"
337 , "import ModuleA"
341 , "import ModuleA"
339− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
340− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
341 expectDiagnostics
345 expectDiagnostics
342 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
343 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -359,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
359 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
360 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
362− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
363− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
364 expectDiagnostics
368 expectDiagnostics
365 [ ( "Main.hs"
369 [ ( "Main.hs"
366 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -375,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
375 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
376 , "foo a = 1"
380 , "foo a = 1"
378− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
379 expectDiagnostics
383 expectDiagnostics
380 [ ( "Foo.hs"
384 [ ( "Foo.hs"
381 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -426,13 +430,32 @@ diagnosticTests = testGroup "diagnostics"
426 , "foo :: Int"
430 , "foo :: Int"
427 , "foo = 1 {-|-}"
431 , "foo = 1 {-|-}"
429− _ <- openDoc' "Foo.hs" "haskell" fooContent
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
430 expectDiagnostics
434 expectDiagnostics
431 [ ( "Foo.hs"
435 [ ( "Foo.hs"
432 , [(DsError, (2, 8), "Parse error on input")
436 , [(DsError, (2, 8), "Parse error on input")
440+ , testSessionWait "strip file path" $ do
444+ [ "module " <> name <> " where"
445+ , "value :: Maybe ()"
448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449+ notification <- skipManyTill anyMessage diagnostic
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
438codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -459,29 +482,25 @@ watchedFilesTests :: TestTree
459watchedFilesTests = testGroup "watched files"
482watchedFilesTests = testGroup "watched files"
460 [ testSession' "workspace files" $ \sessionDir -> do
483 [ testSession' "workspace files" $ \sessionDir -> do
461 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
484 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
462− _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
463 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
486 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
465− -- 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):
466 -- - /path-to-workspace/WatchedFilesMissingModule.hs
489 -- - /path-to-workspace/WatchedFilesMissingModule.hs
467 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
490 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
468− -- - WatchedFilesMissingModule.hs
469− -- - WatchedFilesMissingModule.lhs
470− -- - src/WatchedFilesMissingModule.hs
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
471− -- - src/WatchedFilesMissingModule.lhs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
472− liftIO $ length watchedFileRegs @?= 6
493+ liftIO $ length watchedFileRegs @?= 4
474 , testSession' "non workspace file" $ \sessionDir -> do
495 , testSession' "non workspace file" $ \sessionDir -> do
475 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
496 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
476− _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
477 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
498 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
479− -- 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):
480 -- - /path-to-workspace/WatchedFilesMissingModule.hs
501 -- - /path-to-workspace/WatchedFilesMissingModule.hs
481 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
502 -- - /path-to-workspace/WatchedFilesMissingModule.lhs
482− -- - WatchedFilesMissingModule.hs
483− -- - WatchedFilesMissingModule.lhs
484− liftIO $ length watchedFileRegs @?= 4
503+ liftIO $ length watchedFileRegs @?= 2
486 -- TODO add a test for didChangeWorkspaceFolder
505 -- TODO add a test for didChangeWorkspaceFolder
@@ -494,7 +513,7 @@ renameActionTests = testGroup "rename actions"
494 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
495 , "foo argName = argNme"
514 , "foo argName = argNme"
497− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
498 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
499 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
500 executeCodeAction action
519 executeCodeAction action
@@ -512,7 +531,7 @@ renameActionTests = testGroup "rename actions"
512 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
513 , "foo = maybToList"
532 , "foo = maybToList"
515− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
516 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
517 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
518 executeCodeAction action
537 executeCodeAction action
@@ -530,7 +549,7 @@ renameActionTests = testGroup "rename actions"
530 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
531 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
533− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
534 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
535 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
536 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -542,7 +561,7 @@ renameActionTests = testGroup "rename actions"
542 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
543 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
545− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
546 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
547 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
548 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -565,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
565 , "func :: _"
584 , "func :: _"
566 , "func x = x"
585 , "func x = x"
568− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
569 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
570 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
571 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -585,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
585 , "func :: _"
604 , "func :: _"
586 , "func x y = x + y"
605 , "func x y = x + y"
588− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
589 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
590 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
591 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -608,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
608 , " y = x * 2"
627 , " y = x * 2"
609 , " in y"
628 , " in y"
611− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
612 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
613 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
614 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -633,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
633 let contentA = T.unlines
652 let contentA = T.unlines
634 [ "module ModuleA where"
653 [ "module ModuleA where"
636− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
637 let contentB = T.unlines
656 let contentB = T.unlines
638 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
639 , "module ModuleB where"
658 , "module ModuleB where"
@@ -641,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
641 , "stuffB :: Integer"
660 , "stuffB :: Integer"
642 , "stuffB = 123"
661 , "stuffB = 123"
644− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
645 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
646 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
647 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -659,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
659 let contentA = T.unlines
678 let contentA = T.unlines
660 [ "module ModuleA where"
679 [ "module ModuleA where"
662− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
663 let contentB = T.unlines
682 let contentB = T.unlines
664 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
665 , "module ModuleB where"
684 , "module ModuleB where"
@@ -667,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
667 , "stuffB :: Integer"
686 , "stuffB :: Integer"
668 , "stuffB = 123"
687 , "stuffB = 123"
670− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
671 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
672 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
673 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -689,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
689 , "stuffB = 123"
708 , "stuffB = 123"
690 , "stuffC = ()"
709 , "stuffC = ()"
692− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
693 let contentB = T.unlines
712 let contentB = T.unlines
694 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
695 , "module ModuleB where"
714 , "module ModuleB where"
696 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
697 , "main = print stuffB"
716 , "main = print stuffB"
699− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
700 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
701 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
702 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -718,22 +737,18 @@ removeImportTests = testGroup "remove import actions"
718 , "stuffB :: Integer"
737 , "stuffB :: Integer"
719 , "stuffB = 123"
738 , "stuffB = 123"
721− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
722 let contentB = T.unlines
741 let contentB = T.unlines
723 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
724 , "module ModuleB where"
743 , "module ModuleB where"
725 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
726 , "main = print A.stuffB"
745 , "main = print A.stuffB"
728− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
729 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
730 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
731 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
732−#if MIN_GHC_API_VERSION(8,6,0)
733 liftIO $ "Remove !!, <?> from import" @=? actionTitle
751 liftIO $ "Remove !!, <?> from import" @=? actionTitle
735− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
737 executeCodeAction action
752 executeCodeAction action
738 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
739 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -750,14 +765,14 @@ removeImportTests = testGroup "remove import actions"
750 , "stuffB :: Integer"
765 , "stuffB :: Integer"
751 , "stuffB = 123"
766 , "stuffB = 123"
753− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
754 let contentB = T.unlines
769 let contentB = T.unlines
755 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756 , "module ModuleB where"
771 , "module ModuleB where"
757 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
758 , "main = print stuffB"
773 , "main = print stuffB"
760− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
761 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
762 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
763 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -777,14 +792,14 @@ removeImportTests = testGroup "remove import actions"
777 , "data D = A | B"
792 , "data D = A | B"
778 , "data E = F"
793 , "data E = F"
780− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
781 let contentB = T.unlines
796 let contentB = T.unlines
782 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
783 , "module ModuleB where"
798 , "module ModuleB where"
784 , "import ModuleA (D(A,B), E(F))"
799 , "import ModuleA (D(A,B), E(F))"
785 , "main = B"
800 , "main = B"
787− docB <- openDoc' "ModuleB.hs" "haskell" contentB
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
788 _ <- waitForDiagnostics
803 _ <- waitForDiagnostics
789 [CACodeAction action@CodeAction { _title = actionTitle }]
804 [CACodeAction action@CodeAction { _title = actionTitle }]
790 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -925,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
927 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
928− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
929− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
930 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
931 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
932 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -966,6 +981,8 @@ suggestImportTests = testGroup "suggest import actions"
966 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
981 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
967 , test True [] "f = pack" [] "import Data.Text (pack)"
982 , test True [] "f = pack" [] "import Data.Text (pack)"
968 , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
983 , 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 ((&))"
@@ -974,7 +991,7 @@ suggestImportTests = testGroup "suggest import actions"
974 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
975 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
976 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
977− doc <- openDoc' "Test.hs" "haskell" before
994+ doc <- createDoc "Test.hs" "haskell" before
978 _diags <- waitForDiagnostics
995 _diags <- waitForDiagnostics
979 let defLine = length imps + 1
996 let defLine = length imps + 1
980 range = Range (Position defLine 0) (Position defLine maxBound)
997 range = Range (Position defLine 0) (Position defLine maxBound)
@@ -1034,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
1036 template initialContent range expectedAction expectedContents = do
1053 template initialContent range expectedAction expectedContents = do
1037− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1038 _ <- waitForDiagnostics
1055 _ <- waitForDiagnostics
1039 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 CACodeAction action@CodeAction { _title = actionTitle } : _
1040 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1057,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
1058 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
1060− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1061 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
1062 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
1063 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1081,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
1082 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
1084− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1085 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
1086 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
1087 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1120,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
1122 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
1123− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1124− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
1125 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
1126 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
1127 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1140,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
1140 [ "module Testing where"
1157 [ "module Testing where"
1141 , "import Data.Mape"
1158 , "import Data.Mape"
1143− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
1144 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
1145 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1146 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1177,7 +1194,7 @@ fillTypedHoleTests = let
1177 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
1178 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
1179 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
1180− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
1181 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
1182 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1183 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1225,7 +1242,7 @@ addSigActionTests = let
1225 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
1226 let originalCode = before def
1243 let originalCode = before def
1227 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
1228− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1229 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
1230 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1231 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1257,7 +1274,7 @@ addSigLensesTests = let
1257 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1258 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1259 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1260− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1261 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1262 executeCommand c
1279 executeCommand c
1263 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
@@ -1279,27 +1296,19 @@ addSigLensesTests = let
1282−findDefinitionAndHoverTests :: TestTree
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1283−findDefinitionAndHoverTests = let
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1285− tst (get, check) pos targetRange title = testSession title $ do
1286− doc <- openTestDataDoc sourceFilePath
1287− found <- get doc pos
1288− check found targetRange
1290− checkDefs :: [Location] -> Session [Expect] -> Session ()
1291− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1293− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1294− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1295− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1296− check (ExpectLocation expectedLocation) = do
1305+ check (ExpectLocation expectedLocation) = do
1297− assertNDefinitionsFound 1 defs
1306+ assertNDefinitionsFound 1 defs
1298− liftIO $ head defs @?= expectedLocation
1307+ liftIO $ head defs @?= expectedLocation
1299− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1300− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1301− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1302− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1304 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1305 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1307,6 +1316,17 @@ findDefinitionAndHoverTests = let
1307 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1308 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
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
1310 checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1311 checkHover hover expectations = traverse_ check =<< expectations where
1331 checkHover hover expectations = traverse_ check =<< expectations where
@@ -1351,7 +1371,8 @@ findDefinitionAndHoverTests = let
1352 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1353 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1354− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1356 test runDef runHover look expect = testM runDef runHover look (return expect)
1377 test runDef runHover look expect = testM runDef runHover look (return expect)
@@ -1446,8 +1467,17 @@ findDefinitionAndHoverTests = let
1446 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1447 no = const Nothing -- don't run this test at all
1468 no = const Nothing -- don't run this test at all
1470+checkFileCompiles :: FilePath -> TestTree
1471+checkFileCompiles fp =
1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473+ void (openTestDataDoc (dir </> fp))
1474+ expectNoMoreDiagnostics 0.5
1449pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1450−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1451 let content =
1481 let content =
1452 T.unlines
1482 T.unlines
1453 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1461,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1461 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1462 , "foo a b = a + c"
1492 , "foo a b = a + c"
1464− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1465 expectDiagnostics
1495 expectDiagnostics
1466 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1467 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1488,7 +1518,7 @@ cppTests =
1488 run $ expectError content (2, 1)
1518 run $ expectError content (2, 1)
1490 , testSessionWait "cpp-ghcide" $ do
1520 , testSessionWait "cpp-ghcide" $ do
1491− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1492 ["{-# LANGUAGE CPP #-}"
1522 ["{-# LANGUAGE CPP #-}"
1493 ,"main ="
1523 ,"main ="
1494 ,"#ifdef __GHCIDE__"
1524 ,"#ifdef __GHCIDE__"
@@ -1502,7 +1532,7 @@ cppTests =
1503 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1504 expectError content cursor = do
1534 expectError content cursor = do
1505− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1506 expectDiagnostics
1536 expectDiagnostics
1507 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1508 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1518,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1518 , "module Testing where"
1548 , "module Testing where"
1519 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1521− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1522 expectDiagnostics
1552 expectDiagnostics
1523 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1524 [(DsError, (2, 8), "Variable not in scope: z")]
1554 [(DsError, (2, 8), "Variable not in scope: z")]
@@ -1551,8 +1581,8 @@ safeTests =
1551 ,"safeId = trustWorthyId"
1581 ,"safeId = trustWorthyId"
1554− _ <- openDoc' "A.hs" "haskell" sourceA
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1555− _ <- openDoc' "B.hs" "haskell" sourceB
1585+ _ <- createDoc "B.hs" "haskell" sourceB
1556 expectNoMoreDiagnostics 1 ]
1586 expectNoMoreDiagnostics 1 ]
1558thTests :: TestTree
1588thTests :: TestTree
@@ -1580,8 +1610,8 @@ thTests =
1580 "b :: Integer",
1610 "b :: Integer",
1581 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1583− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1584− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1585 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1586 , testSessionWait "newtype-closure" $ do
1616 , testSessionWait "newtype-closure" $ do
1587 let sourceA =
1617 let sourceA =
@@ -1601,8 +1631,8 @@ thTests =
1601 ,"import A"
1631 ,"import A"
1602 ,"b :: Int"
1632 ,"b :: Int"
1603 ,"b = $( a )" ]
1633 ,"b = $( a )" ]
1604− _ <- openDoc' "A.hs" "haskell" sourceA
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1605− _ <- openDoc' "B.hs" "haskell" sourceB
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1606 return ()
1636 return ()
@@ -1611,7 +1641,7 @@ completionTests
1611 = testGroup "completion"
1641 = testGroup "completion"
1612 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1613 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1614− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1615 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1616 liftIO $ map dropDocs compls @?=
1646 liftIO $ map dropDocs compls @?=
1617 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1623,7 +1653,7 @@ completionTests
1624 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1625 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1626− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1627 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1628 liftIO $ map dropDocs compls @?=
1658 liftIO $ map dropDocs compls @?=
1629 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1635,7 +1665,7 @@ completionTests
1636 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1637 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1667 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
1639 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1640 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1641 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1652,7 +1682,7 @@ completionTests
1652 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1653 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1654 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1684 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
1656 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1657 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1658 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
@@ -1666,7 +1696,7 @@ completionTests
1667 , testSessionWait "keyword" $ do
1697 , testSessionWait "keyword" $ do
1668 let source = T.unlines ["module A where", "f = newty"]
1698 let source = T.unlines ["module A where", "f = newty"]
1669− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
1670 compls <- getCompletions docId (Position 1 9)
1700 compls <- getCompletions docId (Position 1 9)
1671 liftIO $ compls @?= [keywordItem "newtype"]
1701 liftIO $ compls @?= [keywordItem "newtype"]
1672 , testSessionWait "type context" $ do
1702 , testSessionWait "type context" $ do
@@ -1675,7 +1705,7 @@ completionTests
1675 , "module A () where"
1705 , "module A () where"
1676 , "f = f"
1706 , "f = f"
1678− docId <- openDoc' "A.hs" "haskell" source
1708+ docId <- createDoc "A.hs" "haskell" source
1679 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1680 changeDoc docId
1710 changeDoc docId
1681 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
@@ -1743,7 +1773,7 @@ outlineTests = testGroup
1743 "outline"
1773 "outline"
1744 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1745 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1775 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
1747 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1748 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1749 [ moduleSymbol
1779 [ moduleSymbol
@@ -1756,7 +1786,7 @@ outlineTests = testGroup
1757 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1758 let source = T.unlines ["class A a where", "instance A () where"]
1788 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
1760 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1761 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1762 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1764,7 +1794,7 @@ outlineTests = testGroup
1765 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1766 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1767− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1768 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1769 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1770 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1773,7 +1803,7 @@ outlineTests = testGroup
1773 , "type family A a"
1803 , "type family A a"
1774 , "type instance A () = ()"
1804 , "type instance A () = ()"
1776− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1777 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1778 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1779 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1781,7 +1811,7 @@ outlineTests = testGroup
1782 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1783 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1784− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1785 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1786 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1787 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1790,7 +1820,7 @@ outlineTests = testGroup
1790 , "data family A a"
1820 , "data family A a"
1791 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1793− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1794 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1795 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1796 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1798,36 +1828,36 @@ outlineTests = testGroup
1799 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1800 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1801− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1802 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1803 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1804 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1805 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1806 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1807− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1808 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1809 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1810 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1811 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1812 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1813− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1814 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1815 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1816 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1817 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1818 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1819− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1820 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1821 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1822 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1823 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1824− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1825 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1826 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1827 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1828 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1829 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1830− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1831 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1832 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1833 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1835,9 +1865,21 @@ outlineTests = testGroup
1835 (R 0 0 0 10)
1865 (R 0 0 0 10)
1836 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
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)
1838 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1839 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1840− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
1841 symbols <- getDocumentSymbols docId
1883 symbols <- getDocumentSymbols docId
1842 liftIO $ symbols @?= Left
1884 liftIO $ symbols @?= Left
1843 [docSymbolWithChildren "imports"
1885 [docSymbolWithChildren "imports"
@@ -1848,7 +1890,7 @@ outlineTests = testGroup
1849 , testSessionWait "multiple import" $ do
1891 , testSessionWait "multiple import" $ do
1850 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1851− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
1852 symbols <- getDocumentSymbols docId
1894 symbols <- getDocumentSymbols docId
1853 liftIO $ symbols @?= Left
1895 liftIO $ symbols @?= Left
1854 [docSymbolWithChildren "imports"
1896 [docSymbolWithChildren "imports"
@@ -1863,7 +1905,7 @@ outlineTests = testGroup
1863 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1864 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1866− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1867 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1868 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1869 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1871,7 +1913,7 @@ outlineTests = testGroup
1871 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1872 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1874− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1875 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1876 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
@@ -1884,6 +1926,8 @@ outlineTests = testGroup
1884 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1885 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1886 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1928 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)
1887 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
@@ -1905,6 +1949,13 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1905xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1906xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1908data Expect
1959data Expect
1909 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1910 | ExpectLocation Location
1961 | ExpectLocation Location
@@ -1982,6 +2033,7 @@ cradleTests :: TestTree
1982cradleTests = testGroup "cradle"
2033cradleTests = testGroup "cradle"
1983 [testGroup "dependencies" [sessionDepsArePickedUp]
2034 [testGroup "dependencies" [sessionDepsArePickedUp]
1984 ,testGroup "loading" [loadCradleOnlyonce]
2035 ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
1987loadCradleOnlyonce :: TestTree
2039loadCradleOnlyonce :: TestTree
@@ -1996,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"
1996 test dir
2048 test dir
1997 implicit dir = test dir
2049 implicit dir = test dir
1998 test _dir = do
2050 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"
2000 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2001 liftIO $ length msgs @?= 1
2053 liftIO $ length msgs @?= 1
2002 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2003 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2004 liftIO $ length msgs @?= 0
2056 liftIO $ length msgs @?= 0
2005− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2006 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2007 liftIO $ length msgs @?= 0
2059 liftIO $ length msgs @?= 0
2062+dependentFileTest :: TestTree
2063+dependentFileTest = testGroup "addDependentFile"
2064+ [testGroup "file-changed" [testSession' "test" test]
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"
2077+ , " qAddDependentFile \"dep-file.txt\""
2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"
2079+ , " if f == \"B\" then [| 1 |] else lift f)"
2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]
2082+ _ <-createDoc "Foo.hs" "haskell" fooContent
2083+ doc <- createDoc "Baz.hs" "haskell" bazContent
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
2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well
2094+ changeDoc doc [change]
2095+ expectDiagnostics [("Foo.hs", [])]
2010cradleLoadedMessage :: Session FromServerMessage
2098cradleLoadedMessage :: Session FromServerMessage
2011cradleLoadedMessage = satisfy $ \case
2099cradleLoadedMessage = satisfy $ \case
2012 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -2015,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case
2015cradleLoadedMethod :: T.Text
2103cradleLoadedMethod :: T.Text
2016cradleLoadedMethod = "ghcide/cradle/loaded"
2104cradleLoadedMethod = "ghcide/cradle/loaded"
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
2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2115+ [ "GHC_PACKAGE_PATH"
2116+ , "GHC_ENVIRONMENT"
2117+ , "HASKELL_DIST_DIR"
2118+ , "HASKELL_PACKAGE_SANDBOX"
2119+ , "HASKELL_PACKAGE_SANDBOXES"
2121+ restore var Nothing = unsetEnv var
2122+ restore var (Just val) = setEnv var val True
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
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
2018sessionDepsArePickedUp :: TestTree
2156sessionDepsArePickedUp :: TestTree
2019sessionDepsArePickedUp = testSession'
2157sessionDepsArePickedUp = testSession'
2020 "session-deps-are-picked-up"
2158 "session-deps-are-picked-up"
@@ -2024,7 +2162,7 @@ sessionDepsArePickedUp = testSession'
2024 (dir </> "hie.yaml")
2162 (dir </> "hie.yaml")
2025 "cradle: {direct: {arguments: []}}"
2163 "cradle: {direct: {arguments: []}}"
2026 -- Open without OverloadedStrings and expect an error.
2164 -- Open without OverloadedStrings and expect an error.
2027− doc <- openDoc' "Foo.hs" "haskell" fooContent
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
2028 expectDiagnostics
2166 expectDiagnostics
2029 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2030 -- Update hie.yaml to enable OverloadedStrings.
2168 -- Update hie.yaml to enable OverloadedStrings.
@@ -2059,6 +2197,9 @@ sessionDepsArePickedUp = testSession'
2059testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
2060testSession name = testCase name . run
2198testSession name = testCase name . run
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2062testSession' :: String -> (FilePath -> Session ()) -> TestTree
2203testSession' :: String -> (FilePath -> Session ()) -> TestTree
2063testSession' name = testCase name . run'
2204testSession' name = testCase name . run'
@@ -2093,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)
2093run :: Session a -> IO a
2234run :: Session a -> IO a
2094run s = withTempDir $ \dir -> runInDir dir s
2235run s = withTempDir $ \dir -> runInDir dir s
2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239+ copyTestDataFiles dir prefix
2240+ runInDir dir (s dir)
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)
2096run' :: (FilePath -> Session a) -> IO a
2250run' :: (FilePath -> Session a) -> IO a
2097run' s = withTempDir $ \dir -> runInDir dir (s dir)
2251run' s = withTempDir $ \dir -> runInDir dir (s dir)
@@ -2104,11 +2258,6 @@ runInDir dir s = do
2104 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2105 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
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)
2113 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
2262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
2114 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
@@ -2127,7 +2276,7 @@ runInDir dir s = do
2127openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2128openTestDataDoc path = do
2277openTestDataDoc path = do
2129 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2130− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
2132findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2133findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -2168,20 +2317,6 @@ unitTests = do
2168 uriToFilePath' uri @?= Just ""
2317 uriToFilePath' uri @?= Just ""
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])
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'
2185positionMappingTests :: TestTree
2320positionMappingTests :: TestTree
2186positionMappingTests =
2321positionMappingTests =
2187 testGroup "position mapping"
2322 testGroup "position mapping"