@@ -1,6 +1,7 @@
11-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4+{-# LANGUAGE AllowAmbiguousTypes #-}
45{-# LANGUAGE DuplicateRecordFields #-}
56{-# LANGUAGE PatternSynonyms #-}
67{-# LANGUAGE CPP #-}
@@ -9,31 +10,32 @@
910module Main (main) where
1011
1112import Control.Applicative.Combinators
12−import Control.Exception (catch)
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
1315import Control.Monad
1416import Control.Monad.IO.Class (liftIO)
15−import Data.Aeson (Value)
16−import Data.Char (toLower)
17+import Data.Aeson (FromJSON, Value)
1718import Data.Foldable
18−import Data.List
19+import Data.List.Extra
1920import Data.Rope.UTF16 (Rope)
2021import qualified Data.Rope.UTF16 as Rope
2122import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
2223import Development.IDE.GHC.Util
2324import qualified Data.Text as T
25+import Data.Typeable
2426import Development.IDE.Spans.Common
2527import Development.IDE.Test
2628import Development.IDE.Test.Runfiles
2729import Development.IDE.Types.Location
2830import Development.Shake (getDirectoryFilesIO)
29−import qualified Language.Haskell.LSP.Test as LSPTest
30−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
3132import Language.Haskell.LSP.Messages
3233import Language.Haskell.LSP.Types
3334import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
3436import Language.Haskell.LSP.VFS (applyChange)
3537import Network.URI
36−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
3739import System.FilePath
3840import System.IO.Extra
3941import System.Directory
@@ -47,31 +49,35 @@ import Test.Tasty.QuickCheck
4749import Data.Maybe
4850
4951main :: IO ()
50−main = defaultMainWithRerun $ testGroup "HIE"
51− [ testSession "open close" $ do
52− doc <- openDoc' "Testing.hs" "haskell" ""
53− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
54− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
55− closeDoc doc
56− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
57− , initializeResponseTests
58− , completionTests
59− , cppTests
60− , diagnosticTests
61− , codeActionTests
62− , codeLensesTests
63− , outlineTests
64− , findDefinitionAndHoverTests
65− , pluginTests
66− , preprocessorTests
67− , thTests
68− , safeTests
69− , unitTests
70− , haddockTests
71− , positionMappingTests
72− , watchedFilesTests
73− , cradleTests
74− ]
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+ ]
7581
7682initializeResponseTests :: TestTree
7783initializeResponseTests = withResource acquire release tests where
@@ -106,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where
106112 , chk "NO doc link" _documentLinkProvider Nothing
107113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
108114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
109− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
110116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
111117 , chk "NO experimental" _experimental Nothing
112118 ] where
@@ -122,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where
122128 chk title getActual expected =
123129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
124130
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+
125140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
126− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
127142 innerCaps _ = error "this test only expects inner capabilities"
128143
129144 acquire :: IO InitializeResponse
@@ -137,7 +152,7 @@ diagnosticTests :: TestTree
137152diagnosticTests = testGroup "diagnostics"
138153 [ testSessionWait "fix syntax error" $ do
139154 let content = T.unlines [ "module Testing wher" ]
140− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
141156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
142157 let change = TextDocumentContentChangeEvent
143158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -148,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"
148163 expectDiagnostics [("Testing.hs", [])]
149164 , testSessionWait "introduce syntax error" $ do
150165 let content = T.unlines [ "module Testing where" ]
151− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
152167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
153168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
154169 let change = TextDocumentContentChangeEvent
@@ -166,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
166181 , "bar :: Int -> Int -> Int"
167182 , "bar a b = cd + b"
168183 ]
169− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
170185 expectDiagnostics
171186 [ ( "Testing.hs"
172187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -180,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
180195 , "foo :: Int -> String -> Int"
181196 , "foo a b = a + b"
182197 ]
183− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
184199 expectDiagnostics
185200 [ ( "Testing.hs"
186201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -192,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
192207 , "foo :: Int -> String"
193208 , "foo a = _ a"
194209 ]
195− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
196211 expectDiagnostics
197212 [ ( "Testing.hs"
198213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -214,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
214229 [ ("A.hs", [(DsError, (2,4), aMessage)])
215230 , ("B.hs", [(DsError, (3,4), bMessage)])]
216231 deferralTest title binding msg = testSessionWait title $ do
217− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
218− _ <- openDoc' "B.hs" "haskell" sourceB
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
233+ _ <- createDoc "B.hs" "haskell" sourceB
219234 expectDiagnostics $ expectedDs msg
220235 in
221236 [ deferralTest "type error" "True" "Couldn't match expected type"
222237 , deferralTest "typed hole" "_" "Found hole"
223238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
224− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
225239 ]
226240
227241 , testSessionWait "remove required module" $ do
228242 let contentA = T.unlines [ "module ModuleA where" ]
229− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
230244 let contentB = T.unlines
231245 [ "module ModuleB where"
232246 , "import ModuleA"
233247 ]
234− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
235249 let change = TextDocumentContentChangeEvent
236250 { _range = Just (Range (Position 0 0) (Position 0 20))
237251 , _rangeLength = Nothing
@@ -244,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
244258 [ "module ModuleB where"
245259 , "import ModuleA"
246260 ]
247− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
248262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
249263 let contentA = T.unlines [ "module ModuleA where" ]
250− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
251265 expectDiagnostics [("ModuleB.hs", [])]
252266 , testSessionWait "add missing module (non workspace)" $ do
253267 let contentB = T.unlines
254268 [ "module ModuleB where"
255269 , "import ModuleA"
256270 ]
257− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
258272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
259273 let contentA = T.unlines [ "module ModuleA where" ]
260− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
261275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
262276 , testSessionWait "cyclic module dependency" $ do
263277 let contentA = T.unlines
@@ -268,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
268282 [ "module ModuleB where"
269283 , "import ModuleA"
270284 ]
271− _ <- openDoc' "ModuleA.hs" "haskell" contentA
272− _ <- openDoc' "ModuleB.hs" "haskell" contentB
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
273287 expectDiagnostics
274288 [ ( "ModuleA.hs"
275289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -290,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
290304 let contentBboot = T.unlines
291305 [ "module ModuleB where"
292306 ]
293− _ <- openDoc' "ModuleA.hs" "haskell" contentA
294− _ <- openDoc' "ModuleB.hs" "haskell" contentB
295− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
296310 expectDiagnostics []
297311 , testSessionWait "correct reference used with hs-boot" $ do
298312 let contentB = T.unlines
@@ -314,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
314328 -- resolved to the hs-boot file
315329 , "y = x"
316330 ]
317− _ <- openDoc' "ModuleB.hs" "haskell" contentB
318− _ <- openDoc' "ModuleA.hs" "haskell" contentA
319− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
320− _ <- openDoc' "ModuleC.hs" "haskell" contentC
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
321335 expectDiagnostics []
322336 , testSessionWait "redundant import" $ do
323337 let contentA = T.unlines ["module ModuleA where"]
@@ -326,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
326340 , "module ModuleB where"
327341 , "import ModuleA"
328342 ]
329− _ <- openDoc' "ModuleA.hs" "haskell" contentA
330− _ <- openDoc' "ModuleB.hs" "haskell" contentB
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
331345 expectDiagnostics
332346 [ ( "ModuleB.hs"
333347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -349,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
349363 , "wrong1 = ThisList.map"
350364 , "wrong2 = BaseList.x"
351365 ]
352− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
353− _ <- openDoc' "Main.hs" "haskell" mainContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
354368 expectDiagnostics
355369 [ ( "Main.hs"
356370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -365,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
365379 , "foo :: Ord a => a -> Int"
366380 , "foo a = 1"
367381 ]
368− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
369383 expectDiagnostics
370384 [ ( "Foo.hs"
371385 -- The test is to make sure that warnings contain unqualified names
@@ -390,14 +404,14 @@ diagnosticTests = testGroup "diagnostics"
390404 Just pathB <- pure $ uriToFilePath uriB
391405 uriB <- pure $
392406 let (drive, suffix) = splitDrive pathB
393− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
394408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
395409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
396410 uriA <- getDocUri "A/A.hs"
397411 Just pathA <- pure $ uriToFilePath uriA
398412 uriA <- pure $
399413 let (drive, suffix) = splitDrive pathA
400− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
401415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
402416 let a = TextDocumentIdentifier uriA
403417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
@@ -410,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
410424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
411425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
412426 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
413459 ]
414460
415461codeActionTests :: TestTree
@@ -435,26 +481,26 @@ codeLensesTests = testGroup "code lenses"
435481watchedFilesTests :: TestTree
436482watchedFilesTests = testGroup "watched files"
437483 [ testSession' "workspace files" $ \sessionDir -> do
438− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
439− _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
440− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
441−
442− -- Expect 6 subscriptions (A does not get any because it's VFS):
443− -- - /path-to-workspace/B.hs
444− -- - /path-to-workspace/B.lhs
445− -- - B.hs
446− -- - B.lhs
447− -- - src/B.hs
448− -- - src/B.lhs
449− liftIO $ length watchedFileRegs @?= 6
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
450494
451495 , testSession' "non workspace file" $ \sessionDir -> do
452− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
453− _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
454− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
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
455499
456− -- Expect 4 subscriptions:
457− liftIO $ length watchedFileRegs @?= 4
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
458504
459505 -- TODO add a test for didChangeWorkspaceFolder
460506 ]
@@ -467,7 +513,7 @@ renameActionTests = testGroup "rename actions"
467513 , "foo :: Int -> Int"
468514 , "foo argName = argNme"
469515 ]
470− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
471517 _ <- waitForDiagnostics
472518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
473519 executeCodeAction action
@@ -485,7 +531,7 @@ renameActionTests = testGroup "rename actions"
485531 , "foo :: Maybe a -> [a]"
486532 , "foo = maybToList"
487533 ]
488− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
489535 _ <- waitForDiagnostics
490536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
491537 executeCodeAction action
@@ -503,7 +549,7 @@ renameActionTests = testGroup "rename actions"
503549 , "foo :: Char -> Char -> Char -> Char"
504550 , "foo argument1 argument2 argument3 = argumentX"
505551 ]
506− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
507553 _ <- waitForDiagnostics
508554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
509555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -515,7 +561,7 @@ renameActionTests = testGroup "rename actions"
515561 , "monus x y = max 0 (x - y)"
516562 , "foo x y = x `monnus` y"
517563 ]
518− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
519565 _ <- waitForDiagnostics
520566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
521567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -538,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
538584 , "func :: _"
539585 , "func x = x"
540586 ]
541− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
542588 _ <- waitForDiagnostics
543589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
544590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -558,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
558604 , "func :: _"
559605 , "func x y = x + y"
560606 ]
561− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
562608 _ <- waitForDiagnostics
563609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
564610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -581,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
581627 , " y = x * 2"
582628 , " in y"
583629 ]
584− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
585631 _ <- waitForDiagnostics
586632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
587633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -606,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
606652 let contentA = T.unlines
607653 [ "module ModuleA where"
608654 ]
609− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
610656 let contentB = T.unlines
611657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
612658 , "module ModuleB where"
@@ -614,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
614660 , "stuffB :: Integer"
615661 , "stuffB = 123"
616662 ]
617− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
618664 _ <- waitForDiagnostics
619665 [CACodeAction action@CodeAction { _title = actionTitle }]
620666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -632,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
632678 let contentA = T.unlines
633679 [ "module ModuleA where"
634680 ]
635− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
636682 let contentB = T.unlines
637683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
638684 , "module ModuleB where"
@@ -640,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
640686 , "stuffB :: Integer"
641687 , "stuffB = 123"
642688 ]
643− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
644690 _ <- waitForDiagnostics
645691 [CACodeAction action@CodeAction { _title = actionTitle }]
646692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -662,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
662708 , "stuffB = 123"
663709 , "stuffC = ()"
664710 ]
665− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
666712 let contentB = T.unlines
667713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
668714 , "module ModuleB where"
669715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
670716 , "main = print stuffB"
671717 ]
672− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
673719 _ <- waitForDiagnostics
674720 [CACodeAction action@CodeAction { _title = actionTitle }]
675721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -691,22 +737,18 @@ removeImportTests = testGroup "remove import actions"
691737 , "stuffB :: Integer"
692738 , "stuffB = 123"
693739 ]
694− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
695741 let contentB = T.unlines
696742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
697743 , "module ModuleB where"
698744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
699745 , "main = print A.stuffB"
700746 ]
701− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
702748 _ <- waitForDiagnostics
703749 [CACodeAction action@CodeAction { _title = actionTitle }]
704750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
705−#if MIN_GHC_API_VERSION(8,6,0)
706751 liftIO $ "Remove !!, <?> from import" @=? actionTitle
707−#else
708− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
709−#endif
710752 executeCodeAction action
711753 contentAfterAction <- documentContents docB
712754 let expectedContentAfterAction = T.unlines
@@ -723,14 +765,14 @@ removeImportTests = testGroup "remove import actions"
723765 , "stuffB :: Integer"
724766 , "stuffB = 123"
725767 ]
726− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
727769 let contentB = T.unlines
728770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
729771 , "module ModuleB where"
730772 , "import ModuleA (A(..), stuffB)"
731773 , "main = print stuffB"
732774 ]
733− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
734776 _ <- waitForDiagnostics
735777 [CACodeAction action@CodeAction { _title = actionTitle }]
736778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -750,14 +792,14 @@ removeImportTests = testGroup "remove import actions"
750792 , "data D = A | B"
751793 , "data E = F"
752794 ]
753− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
754796 let contentB = T.unlines
755797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756798 , "module ModuleB where"
757799 , "import ModuleA (D(A,B), E(F))"
758800 , "main = B"
759801 ]
760− docB <- openDoc' "ModuleB.hs" "haskell" contentB
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
761803 _ <- waitForDiagnostics
762804 [CACodeAction action@CodeAction { _title = actionTitle }]
763805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -898,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
898940 ]
899941 where
900942 template contentA contentB range expectedAction expectedContentB = do
901− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
902− docB <- openDoc' "ModuleB.hs" "haskell" contentB
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
903945 _ <- waitForDiagnostics
904946 CACodeAction action@CodeAction { _title = actionTitle } : _
905947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -939,6 +981,8 @@ suggestImportTests = testGroup "suggest import actions"
939981 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
940982 , test True [] "f = pack" [] "import Data.Text (pack)"
941983 , 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 ((&))"
942986 ]
943987 ]
944988 where
@@ -947,19 +991,20 @@ suggestImportTests = testGroup "suggest import actions"
947991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
948992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
949993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
950− doc <- openDoc' "Test.hs" "haskell" before
994+ doc <- createDoc "Test.hs" "haskell" before
951995 _diags <- waitForDiagnostics
952996 let defLine = length imps + 1
953997 range = Range (Position defLine 0) (Position defLine maxBound)
954998 actions <- getCodeActions doc range
955− case wanted of
956− False ->
957− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
958− True -> do
959− action <- liftIO $ pickActionWithTitle newImp actions
960− executeCodeAction action
961− contentAfterAction <- documentContents doc
962− liftIO $ after @=? contentAfterAction
999+ if wanted
1000+ then do
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1005+ else
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007+
9631008
9641009addExtensionTests :: TestTree
9651010addExtensionTests = testGroup "add language extension actions"
@@ -1006,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
10061051 ]
10071052 where
10081053 template initialContent range expectedAction expectedContents = do
1009− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
10101055 _ <- waitForDiagnostics
10111056 CACodeAction action@CodeAction { _title = actionTitle } : _
10121057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1029,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10291074 [""
10301075 ,"someOtherCode = ()"
10311076 ]
1032− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10331078 _ <- waitForDiagnostics
10341079 CACodeAction action@CodeAction { _title = actionTitle } : _
10351080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1053,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10531098 [""
10541099 ,"someOtherCode = ()"
10551100 ]
1056− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10571102 _ <- waitForDiagnostics
10581103 CACodeAction action@CodeAction { _title = actionTitle } : _
10591104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1092,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
10921137 ]
10931138 where
10941139 template contentA contentB range expectedAction expectedContentB = do
1095− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1096− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
10971142 _diags <- waitForDiagnostics
10981143 CACodeAction action@CodeAction { _title = actionTitle } : _
10991144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1112,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
11121157 [ "module Testing where"
11131158 , "import Data.Mape"
11141159 ]
1115− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
11161161 _ <- waitForDiagnostics
11171162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
11181163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1149,7 +1194,7 @@ fillTypedHoleTests = let
11491194 newA newB newC = testSession (T.unpack actionTitle) $ do
11501195 let originalCode = sourceCode oldA oldB oldC
11511196 let expectedCode = sourceCode newA newB newC
1152− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
11531198 _ <- waitForDiagnostics
11541199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
11551200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1197,7 +1242,7 @@ addSigActionTests = let
11971242 def >:: sig = testSession (T.unpack def) $ do
11981243 let originalCode = before def
11991244 let expectedCode = after' def sig
1200− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
12011246 _ <- waitForDiagnostics
12021247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
12031248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1229,7 +1274,7 @@ addSigLensesTests = let
12291274 sigSession withMissing def sig = testSession (T.unpack def) $ do
12301275 let originalCode = before withMissing def
12311276 let expectedCode = after' withMissing def sig
1232− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
12331278 [CodeLens {_command = Just c}] <- getCodeLenses doc
12341279 executeCommand c
12351280 modifiedCode <- getDocumentEdit doc
@@ -1251,27 +1296,19 @@ addSigLensesTests = let
12511296 ]
12521297 ]
12531298
1254−findDefinitionAndHoverTests :: TestTree
1255−findDefinitionAndHoverTests = let
1256−
1257− tst (get, check) pos targetRange title = testSession title $ do
1258− doc <- openTestDataDoc sourceFilePath
1259− found <- get doc pos
1260− check found targetRange
1261−
1262− checkDefs :: [Location] -> Session [Expect] -> Session ()
1263− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
12641301
1265− check (ExpectRange expectedRange) = do
1266− assertNDefinitionsFound 1 defs
1267− assertRangeCorrect (head defs) expectedRange
1268− check (ExpectLocation expectedLocation) = do
1269− assertNDefinitionsFound 1 defs
1270− liftIO $ head defs @?= expectedLocation
1271− check ExpectNoDefinitions = do
1272− assertNDefinitionsFound 0 defs
1273− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1274− check _ = pure () -- all other expectations not relevant to getDefinition
1302+ check (ExpectRange expectedRange) = do
1303+ assertNDefinitionsFound 1 defs
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1308+ check ExpectNoDefinitions = do
1309+ assertNDefinitionsFound 0 defs
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
12751312
12761313 assertNDefinitionsFound :: Int -> [a] -> Session ()
12771314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1279,6 +1316,17 @@ findDefinitionAndHoverTests = let
12791316 assertRangeCorrect Location{_range = foundRange} expectedRange =
12801317 liftIO $ expectedRange @=? foundRange
12811318
1319+
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1322+
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1327+
1328+
1329+
12821330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()
12831331 checkHover hover expectations = traverse_ check =<< expectations where
12841332
@@ -1323,7 +1371,8 @@ findDefinitionAndHoverTests = let
13231371
13241372 mkFindTests tests = testGroup "get"
13251373 [ testGroup "definition" $ mapMaybe fst tests
1326− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
13271376
13281377 test runDef runHover look expect = testM runDef runHover look (return expect)
13291378
@@ -1418,8 +1467,17 @@ findDefinitionAndHoverTests = let
14181467 broken = Just . (`xfail` "known broken")
14191468 no = const Nothing -- don't run this test at all
14201469
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+
14211478pluginTests :: TestTree
1422−pluginTests = testSessionWait "plugins" $ do
1479+pluginTests = (`xfail8101` "known broken (#556)")
1480+ $ testSessionWait "plugins" $ do
14231481 let content =
14241482 T.unlines
14251483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1433,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
14331491 , "foo :: Int -> Int -> Int"
14341492 , "foo a b = a + c"
14351493 ]
1436− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
14371495 expectDiagnostics
14381496 [ ( "Testing.hs",
14391497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1460,7 +1518,7 @@ cppTests =
14601518 run $ expectError content (2, 1)
14611519 )
14621520 , testSessionWait "cpp-ghcide" $ do
1463− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
14641522 ["{-# LANGUAGE CPP #-}"
14651523 ,"main ="
14661524 ,"#ifdef __GHCIDE__"
@@ -1474,7 +1532,7 @@ cppTests =
14741532 where
14751533 expectError :: T.Text -> Cursor -> Session ()
14761534 expectError content cursor = do
1477− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
14781536 expectDiagnostics
14791537 [ ( "Testing.hs",
14801538 [(DsError, cursor, "error: unterminated")]
@@ -1490,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do
14901548 , "module Testing where"
14911549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
14921550 ]
1493− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
14941552 expectDiagnostics
14951553 [ ( "Testing.hs",
14961554 [(DsError, (2, 8), "Variable not in scope: z")]
@@ -1523,8 +1581,8 @@ safeTests =
15231581 ,"safeId = trustWorthyId"
15241582 ]
15251583
1526− _ <- openDoc' "A.hs" "haskell" sourceA
1527− _ <- openDoc' "B.hs" "haskell" sourceB
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
15281586 expectNoMoreDiagnostics 1 ]
15291587
15301588thTests :: TestTree
@@ -1552,8 +1610,8 @@ thTests =
15521610 "b :: Integer",
15531611 "b = $(litE $ IntegerL $ a) + n"
15541612 ]
1555− _ <- openDoc' "A.hs" "haskell" sourceA
1556− _ <- openDoc' "B.hs" "haskell" sourceB
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1614+ _ <- createDoc "B.hs" "haskell" sourceB
15571615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
15581616 , testSessionWait "newtype-closure" $ do
15591617 let sourceA =
@@ -1573,8 +1631,8 @@ thTests =
15731631 ,"import A"
15741632 ,"b :: Int"
15751633 ,"b = $( a )" ]
1576− _ <- openDoc' "A.hs" "haskell" sourceA
1577− _ <- openDoc' "B.hs" "haskell" sourceB
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
15781636 return ()
15791637 ]
15801638
@@ -1583,7 +1641,7 @@ completionTests
15831641 = testGroup "completion"
15841642 [ testSessionWait "variable" $ do
15851643 let source = T.unlines ["module A where", "f = hea"]
1586− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
15871645 compls <- getCompletions docId (Position 1 7)
15881646 liftIO $ map dropDocs compls @?=
15891647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1595,7 +1653,7 @@ completionTests
15951653 ]
15961654 , testSessionWait "constructor" $ do
15971655 let source = T.unlines ["module A where", "f = Tru"]
1598− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
15991657 compls <- getCompletions docId (Position 1 7)
16001658 liftIO $ map dropDocs compls @?=
16011659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1607,7 +1665,7 @@ completionTests
16071665 ]
16081666 , testSessionWait "type" $ do
16091667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1610− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
16111669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
16121670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
16131671 compls <- getCompletions docId (Position 2 7)
@@ -1624,7 +1682,7 @@ completionTests
16241682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
16251683 , testSessionWait "qualified" $ do
16261684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1627− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
16281686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
16291687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
16301688 compls <- getCompletions docId (Position 2 15)
@@ -1638,7 +1696,7 @@ completionTests
16381696 ]
16391697 , testSessionWait "keyword" $ do
16401698 let source = T.unlines ["module A where", "f = newty"]
1641− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
16421700 compls <- getCompletions docId (Position 1 9)
16431701 liftIO $ compls @?= [keywordItem "newtype"]
16441702 , testSessionWait "type context" $ do
@@ -1647,7 +1705,7 @@ completionTests
16471705 , "module A () where"
16481706 , "f = f"
16491707 ]
1650− docId <- openDoc' "A.hs" "haskell" source
1708+ docId <- createDoc "A.hs" "haskell" source
16511709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
16521710 changeDoc docId
16531711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
@@ -1715,7 +1773,7 @@ outlineTests = testGroup
17151773 "outline"
17161774 [ testSessionWait "type class" $ do
17171775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1718− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
17191777 symbols <- getDocumentSymbols docId
17201778 liftIO $ symbols @?= Left
17211779 [ moduleSymbol
@@ -1728,7 +1786,7 @@ outlineTests = testGroup
17281786 ]
17291787 , testSessionWait "type class instance " $ do
17301788 let source = T.unlines ["class A a where", "instance A () where"]
1731− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
17321790 symbols <- getDocumentSymbols docId
17331791 liftIO $ symbols @?= Left
17341792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1736,7 +1794,7 @@ outlineTests = testGroup
17361794 ]
17371795 , testSessionWait "type family" $ do
17381796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1739− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
17401798 symbols <- getDocumentSymbols docId
17411799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
17421800 , testSessionWait "type family instance " $ do
@@ -1745,7 +1803,7 @@ outlineTests = testGroup
17451803 , "type family A a"
17461804 , "type instance A () = ()"
17471805 ]
1748− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
17491807 symbols <- getDocumentSymbols docId
17501808 liftIO $ symbols @?= Left
17511809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1753,7 +1811,7 @@ outlineTests = testGroup
17531811 ]
17541812 , testSessionWait "data family" $ do
17551813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1756− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
17571815 symbols <- getDocumentSymbols docId
17581816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
17591817 , testSessionWait "data family instance " $ do
@@ -1762,7 +1820,7 @@ outlineTests = testGroup
17621820 , "data family A a"
17631821 , "data instance A () = A ()"
17641822 ]
1765− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
17661824 symbols <- getDocumentSymbols docId
17671825 liftIO $ symbols @?= Left
17681826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1770,36 +1828,36 @@ outlineTests = testGroup
17701828 ]
17711829 , testSessionWait "constant" $ do
17721830 let source = T.unlines ["a = ()"]
1773− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
17741832 symbols <- getDocumentSymbols docId
17751833 liftIO $ symbols @?= Left
17761834 [docSymbol "a" SkFunction (R 0 0 0 6)]
17771835 , testSessionWait "pattern" $ do
17781836 let source = T.unlines ["Just foo = Just 21"]
1779− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
17801838 symbols <- getDocumentSymbols docId
17811839 liftIO $ symbols @?= Left
17821840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
17831841 , testSessionWait "pattern with type signature" $ do
17841842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1785− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
17861844 symbols <- getDocumentSymbols docId
17871845 liftIO $ symbols @?= Left
17881846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
17891847 , testSessionWait "function" $ do
17901848 let source = T.unlines ["a x = ()"]
1791− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
17921850 symbols <- getDocumentSymbols docId
17931851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
17941852 , testSessionWait "type synonym" $ do
17951853 let source = T.unlines ["type A = Bool"]
1796− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
17971855 symbols <- getDocumentSymbols docId
17981856 liftIO $ symbols @?= Left
17991857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
18001858 , testSessionWait "datatype" $ do
18011859 let source = T.unlines ["data A = C"]
1802− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
18031861 symbols <- getDocumentSymbols docId
18041862 liftIO $ symbols @?= Left
18051863 [ docSymbolWithChildren "A"
@@ -1807,9 +1865,21 @@ outlineTests = testGroup
18071865 (R 0 0 0 10)
18081866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
18091867 ]
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+ ]
18101880 , testSessionWait "import" $ do
18111881 let source = T.unlines ["import Data.Maybe"]
1812− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
18131883 symbols <- getDocumentSymbols docId
18141884 liftIO $ symbols @?= Left
18151885 [docSymbolWithChildren "imports"
@@ -1820,7 +1890,7 @@ outlineTests = testGroup
18201890 ]
18211891 , testSessionWait "multiple import" $ do
18221892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1823− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
18241894 symbols <- getDocumentSymbols docId
18251895 liftIO $ symbols @?= Left
18261896 [docSymbolWithChildren "imports"
@@ -1835,7 +1905,7 @@ outlineTests = testGroup
18351905 [ "{-# language ForeignFunctionInterface #-}"
18361906 , "foreign import ccall \"a\" a :: Int"
18371907 ]
1838− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
18391909 symbols <- getDocumentSymbols docId
18401910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
18411911 , testSessionWait "foreign export" $ do
@@ -1843,7 +1913,7 @@ outlineTests = testGroup
18431913 [ "{-# language ForeignFunctionInterface #-}"
18441914 , "foreign export ccall odd :: Int -> Bool"
18451915 ]
1846− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
18471917 symbols <- getDocumentSymbols docId
18481918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
18491919 ]
@@ -1856,6 +1926,8 @@ outlineTests = testGroup
18561926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
18571927 docSymbolWithChildren name kind loc cc =
18581928 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)
18591931 moduleSymbol name loc cc = DocumentSymbol name
18601932 Nothing
18611933 SkFile
@@ -1877,6 +1949,13 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
18771949xfail :: TestTree -> String -> TestTree
18781950xfail = flip expectFailBecause
18791951
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+
18801959data Expect
18811960 = ExpectRange Range -- Both gotoDef and hover should report this range
18821961 | ExpectLocation Location
@@ -1954,6 +2033,7 @@ cradleTests :: TestTree
19542033cradleTests = testGroup "cradle"
19552034 [testGroup "dependencies" [sessionDepsArePickedUp]
19562035 ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
19572037 ]
19582038
19592039loadCradleOnlyonce :: TestTree
@@ -1968,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"
19682048 test dir
19692049 implicit dir = test dir
19702050 test _dir = do
1971− doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
19722052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
19732053 liftIO $ length msgs @?= 1
19742054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
19752055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
19762056 liftIO $ length msgs @?= 0
1977− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
19782058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
19792059 liftIO $ length msgs @?= 0
19802060
19812061
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+
19822098cradleLoadedMessage :: Session FromServerMessage
19832099cradleLoadedMessage = satisfy $ \case
19842100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -1987,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case
19872103cradleLoadedMethod :: T.Text
19882104cradleLoadedMethod = "ghcide/cradle/loaded"
19892105
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+
19902156sessionDepsArePickedUp :: TestTree
19912157sessionDepsArePickedUp = testSession'
19922158 "session-deps-are-picked-up"
@@ -1996,7 +2162,7 @@ sessionDepsArePickedUp = testSession'
19962162 (dir </> "hie.yaml")
19972163 "cradle: {direct: {arguments: []}}"
19982164 -- Open without OverloadedStrings and expect an error.
1999− doc <- openDoc' "Foo.hs" "haskell" fooContent
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
20002166 expectDiagnostics
20012167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
20022168 -- Update hie.yaml to enable OverloadedStrings.
@@ -2031,6 +2197,9 @@ sessionDepsArePickedUp = testSession'
20312197testSession :: String -> Session () -> TestTree
20322198testSession name = testCase name . run
20332199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
20342203testSession' :: String -> (FilePath -> Session ()) -> TestTree
20352204testSession' name = testCase name . run'
20362205
@@ -2065,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)
20652234run :: Session a -> IO a
20662235run s = withTempDir $ \dir -> runInDir dir s
20672236
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+
20682250run' :: (FilePath -> Session a) -> IO a
20692251run' s = withTempDir $ \dir -> runInDir dir (s dir)
20702252
@@ -2076,11 +2258,6 @@ runInDir dir s = do
20762258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
20772259 createDirectoryIfMissing True $ dir ++ "/Data"
20782260
2079− -- Copy all the test data files to the temporary workspace
2080− testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]
2081− for_ testDataFiles $ \f -> do
2082− createDirectoryIfMissing True $ dir </> takeDirectory f
2083− copyFile ("test/data" </> f) (dir </> f)
20842261
20852262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
20862263 -- HIE calls getXgdDirectory which assumes that HOME is set.
@@ -2099,7 +2276,7 @@ runInDir dir s = do
20992276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
21002277openTestDataDoc path = do
21012278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2102− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
21032280
21042281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
21052282findCodeActions doc range expectedTitles = do
@@ -2140,20 +2317,6 @@ unitTests = do
21402317 uriToFilePath' uri @?= Just ""
21412318 ]
21422319
2143−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2144−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2145−openDoc' fp name contents = do
2146− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2147− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2148− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2149− return res
2150−
2151−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2152−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2153−-- At the moment this is just LSPTest.openDoc' but it may change in the future
2154−-- when/if lsp-test implements WatchedFiles
2155−openDoc'' = LSPTest.openDoc'
2156−
21572320positionMappingTests :: TestTree
21582321positionMappingTests =
21592322 testGroup "position mapping"
@@ -2323,11 +2486,11 @@ nthLine i r
23232486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
23242487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
23252488
2326−getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
2327−getWatchedFilesSubscriptionsUntilProgressEnd = do
2328− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490+getWatchedFilesSubscriptionsUntil = do
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
23292492 return
23302493 [ args
2331− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
23322495 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
23332496 ]