@@ -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,28 +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.Char (toLower)
17+import Data.Aeson (FromJSON, Value)
1618import Data.Foldable
17−import Data.List
19+import Data.List.Extra
1820import Data.Rope.UTF16 (Rope)
1921import qualified Data.Rope.UTF16 as Rope
2022import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
2123import Development.IDE.GHC.Util
2224import qualified Data.Text as T
25+import Data.Typeable
2326import Development.IDE.Spans.Common
2427import Development.IDE.Test
2528import Development.IDE.Test.Runfiles
2629import Development.IDE.Types.Location
27−import qualified Language.Haskell.LSP.Test as LSPTest
28−import Language.Haskell.LSP.Test hiding (openDoc')
30+import Development.Shake (getDirectoryFilesIO)
31+import Language.Haskell.LSP.Test
2932import Language.Haskell.LSP.Messages
3033import Language.Haskell.LSP.Types
3134import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
3236import Language.Haskell.LSP.VFS (applyChange)
33−import System.Environment.Blank (setEnv)
37+import Network.URI
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
3439import System.FilePath
3540import System.IO.Extra
3641import System.Directory
@@ -38,35 +43,41 @@ import Test.QuickCheck
3843import Test.QuickCheck.Instances ()
3944import Test.Tasty
4045import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
4147import Test.Tasty.HUnit
4248import Test.Tasty.QuickCheck
4349import Data.Maybe
4450
4551main :: IO ()
46−main = defaultMain $ testGroup "HIE"
47− [ testSession "open close" $ do
48− doc <- openDoc' "Testing.hs" "haskell" ""
49− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
50− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
51− closeDoc doc
52− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
53− , initializeResponseTests
54− , completionTests
55− , cppTests
56− , diagnosticTests
57− , codeActionTests
58− , codeLensesTests
59− , outlineTests
60− , findDefinitionAndHoverTests
61− , pluginTests
62− , preprocessorTests
63− , thTests
64− , unitTests
65− , haddockTests
66− , positionMappingTests
67− , watchedFilesTests
68− , cradleTests
69− ]
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+ ]
7081
7182initializeResponseTests :: TestTree
7283initializeResponseTests = withResource acquire release tests where
@@ -101,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where
101112 , chk "NO doc link" _documentLinkProvider Nothing
102113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
103114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
104− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
105116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
106117 , chk "NO experimental" _experimental Nothing
107118 ] where
@@ -117,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where
117128 chk title getActual expected =
118129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
119130
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+
120140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
121− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
122142 innerCaps _ = error "this test only expects inner capabilities"
123143
124144 acquire :: IO InitializeResponse
@@ -132,7 +152,7 @@ diagnosticTests :: TestTree
132152diagnosticTests = testGroup "diagnostics"
133153 [ testSessionWait "fix syntax error" $ do
134154 let content = T.unlines [ "module Testing wher" ]
135− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
136156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
137157 let change = TextDocumentContentChangeEvent
138158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -143,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"
143163 expectDiagnostics [("Testing.hs", [])]
144164 , testSessionWait "introduce syntax error" $ do
145165 let content = T.unlines [ "module Testing where" ]
146− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
147167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
148168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
149169 let change = TextDocumentContentChangeEvent
@@ -161,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
161181 , "bar :: Int -> Int -> Int"
162182 , "bar a b = cd + b"
163183 ]
164− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
165185 expectDiagnostics
166186 [ ( "Testing.hs"
167187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -175,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
175195 , "foo :: Int -> String -> Int"
176196 , "foo a b = a + b"
177197 ]
178− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
179199 expectDiagnostics
180200 [ ( "Testing.hs"
181201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -187,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
187207 , "foo :: Int -> String"
188208 , "foo a = _ a"
189209 ]
190− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
191211 expectDiagnostics
192212 [ ( "Testing.hs"
193213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -209,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
209229 [ ("A.hs", [(DsError, (2,4), aMessage)])
210230 , ("B.hs", [(DsError, (3,4), bMessage)])]
211231 deferralTest title binding msg = testSessionWait title $ do
212− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
213− _ <- openDoc' "B.hs" "haskell" sourceB
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
233+ _ <- createDoc "B.hs" "haskell" sourceB
214234 expectDiagnostics $ expectedDs msg
215235 in
216236 [ deferralTest "type error" "True" "Couldn't match expected type"
217237 , deferralTest "typed hole" "_" "Found hole"
218238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
219− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
220239 ]
221240
222241 , testSessionWait "remove required module" $ do
223242 let contentA = T.unlines [ "module ModuleA where" ]
224− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
225244 let contentB = T.unlines
226245 [ "module ModuleB where"
227246 , "import ModuleA"
228247 ]
229− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
230249 let change = TextDocumentContentChangeEvent
231250 { _range = Just (Range (Position 0 0) (Position 0 20))
232251 , _rangeLength = Nothing
@@ -239,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
239258 [ "module ModuleB where"
240259 , "import ModuleA"
241260 ]
242− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
243262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
244263 let contentA = T.unlines [ "module ModuleA where" ]
245− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
246265 expectDiagnostics [("ModuleB.hs", [])]
247266 , testSessionWait "add missing module (non workspace)" $ do
248267 let contentB = T.unlines
249268 [ "module ModuleB where"
250269 , "import ModuleA"
251270 ]
252− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
253272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
254273 let contentA = T.unlines [ "module ModuleA where" ]
255− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
256275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
257276 , testSessionWait "cyclic module dependency" $ do
258277 let contentA = T.unlines
@@ -263,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
263282 [ "module ModuleB where"
264283 , "import ModuleA"
265284 ]
266− _ <- openDoc' "ModuleA.hs" "haskell" contentA
267− _ <- openDoc' "ModuleB.hs" "haskell" contentB
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
268287 expectDiagnostics
269288 [ ( "ModuleA.hs"
270289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -285,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
285304 let contentBboot = T.unlines
286305 [ "module ModuleB where"
287306 ]
288− _ <- openDoc' "ModuleA.hs" "haskell" contentA
289− _ <- openDoc' "ModuleB.hs" "haskell" contentB
290− _ <- 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
291310 expectDiagnostics []
292311 , testSessionWait "correct reference used with hs-boot" $ do
293312 let contentB = T.unlines
@@ -309,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
309328 -- resolved to the hs-boot file
310329 , "y = x"
311330 ]
312− _ <- openDoc' "ModuleB.hs" "haskell" contentB
313− _ <- openDoc' "ModuleA.hs" "haskell" contentA
314− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
315− _ <- 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
316335 expectDiagnostics []
317336 , testSessionWait "redundant import" $ do
318337 let contentA = T.unlines ["module ModuleA where"]
@@ -321,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
321340 , "module ModuleB where"
322341 , "import ModuleA"
323342 ]
324− _ <- openDoc' "ModuleA.hs" "haskell" contentA
325− _ <- openDoc' "ModuleB.hs" "haskell" contentB
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
326345 expectDiagnostics
327346 [ ( "ModuleB.hs"
328347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -344,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
344363 , "wrong1 = ThisList.map"
345364 , "wrong2 = BaseList.x"
346365 ]
347− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
348− _ <- openDoc' "Main.hs" "haskell" mainContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
349368 expectDiagnostics
350369 [ ( "Main.hs"
351370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -360,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
360379 , "foo :: Ord a => a -> Int"
361380 , "foo a = 1"
362381 ]
363− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
364383 expectDiagnostics
365384 [ ( "Foo.hs"
366385 -- The test is to make sure that warnings contain unqualified names
@@ -385,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
385404 Just pathB <- pure $ uriToFilePath uriB
386405 uriB <- pure $
387406 let (drive, suffix) = splitDrive pathB
388− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
389408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
390409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
391410 uriA <- getDocUri "A/A.hs"
392411 Just pathA <- pure $ uriToFilePath uriA
393412 uriA <- pure $
394413 let (drive, suffix) = splitDrive pathA
395− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
396415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
397416 let a = TextDocumentIdentifier uriA
398417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
399− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
400419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
401420 -- Check that if we put a lower-case drive in for A.A
402421 -- the diagnostics for A.B will also be lower-case.
@@ -405,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
405424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
406425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
407426 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
408459 ]
409460
410461codeActionTests :: TestTree
@@ -429,21 +480,28 @@ codeLensesTests = testGroup "code lenses"
429480
430481watchedFilesTests :: TestTree
431482watchedFilesTests = testGroup "watched files"
432− [ testSession "workspace file" $ do
433− _ <- openDoc' "A.hs" "haskell" "module A where"
434− RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)
435− let watchedFileRegs =
436− [ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]
437− liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs
438− , testSession "non workspace file" $ do
439− _ <- openDoc' "/tmp/A.hs" "haskell" "module A where"
440− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
441− let watchedFileRegs =
442− [ args
443− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
444− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
445− ]
446− liftIO $ watchedFileRegs @?= []
483+ [ testSession' "workspace files" $ \sessionDir -> do
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
487+
488+ -- Expect 4 subscriptions (A does not get any because it's VFS):
489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493+ liftIO $ length watchedFileRegs @?= 4
494+
495+ , testSession' "non workspace file" $ \sessionDir -> do
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
499+
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
504+
447505 -- TODO add a test for didChangeWorkspaceFolder
448506 ]
449507
@@ -455,7 +513,7 @@ renameActionTests = testGroup "rename actions"
455513 , "foo :: Int -> Int"
456514 , "foo argName = argNme"
457515 ]
458− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
459517 _ <- waitForDiagnostics
460518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
461519 executeCodeAction action
@@ -473,7 +531,7 @@ renameActionTests = testGroup "rename actions"
473531 , "foo :: Maybe a -> [a]"
474532 , "foo = maybToList"
475533 ]
476− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
477535 _ <- waitForDiagnostics
478536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
479537 executeCodeAction action
@@ -491,7 +549,7 @@ renameActionTests = testGroup "rename actions"
491549 , "foo :: Char -> Char -> Char -> Char"
492550 , "foo argument1 argument2 argument3 = argumentX"
493551 ]
494− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
495553 _ <- waitForDiagnostics
496554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
497555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -503,7 +561,7 @@ renameActionTests = testGroup "rename actions"
503561 , "monus x y = max 0 (x - y)"
504562 , "foo x y = x `monnus` y"
505563 ]
506− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
507565 _ <- waitForDiagnostics
508566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
509567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -526,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
526584 , "func :: _"
527585 , "func x = x"
528586 ]
529− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
530588 _ <- waitForDiagnostics
531589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
532590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -546,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
546604 , "func :: _"
547605 , "func x y = x + y"
548606 ]
549− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
550608 _ <- waitForDiagnostics
551609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
552610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -569,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
569627 , " y = x * 2"
570628 , " in y"
571629 ]
572− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
573631 _ <- waitForDiagnostics
574632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
575633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -594,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
594652 let contentA = T.unlines
595653 [ "module ModuleA where"
596654 ]
597− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
598656 let contentB = T.unlines
599657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
600658 , "module ModuleB where"
@@ -602,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
602660 , "stuffB :: Integer"
603661 , "stuffB = 123"
604662 ]
605− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
606664 _ <- waitForDiagnostics
607665 [CACodeAction action@CodeAction { _title = actionTitle }]
608666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -620,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
620678 let contentA = T.unlines
621679 [ "module ModuleA where"
622680 ]
623− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
624682 let contentB = T.unlines
625683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
626684 , "module ModuleB where"
@@ -628,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
628686 , "stuffB :: Integer"
629687 , "stuffB = 123"
630688 ]
631− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
632690 _ <- waitForDiagnostics
633691 [CACodeAction action@CodeAction { _title = actionTitle }]
634692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -650,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
650708 , "stuffB = 123"
651709 , "stuffC = ()"
652710 ]
653− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
654712 let contentB = T.unlines
655713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
656714 , "module ModuleB where"
657715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
658716 , "main = print stuffB"
659717 ]
660− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
661719 _ <- waitForDiagnostics
662720 [CACodeAction action@CodeAction { _title = actionTitle }]
663721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -679,22 +737,18 @@ removeImportTests = testGroup "remove import actions"
679737 , "stuffB :: Integer"
680738 , "stuffB = 123"
681739 ]
682− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
683741 let contentB = T.unlines
684742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
685743 , "module ModuleB where"
686744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
687745 , "main = print A.stuffB"
688746 ]
689− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
690748 _ <- waitForDiagnostics
691749 [CACodeAction action@CodeAction { _title = actionTitle }]
692750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
693−#if MIN_GHC_API_VERSION(8,6,0)
694751 liftIO $ "Remove !!, <?> from import" @=? actionTitle
695−#else
696− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
697−#endif
698752 executeCodeAction action
699753 contentAfterAction <- documentContents docB
700754 let expectedContentAfterAction = T.unlines
@@ -711,14 +765,14 @@ removeImportTests = testGroup "remove import actions"
711765 , "stuffB :: Integer"
712766 , "stuffB = 123"
713767 ]
714− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
715769 let contentB = T.unlines
716770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
717771 , "module ModuleB where"
718772 , "import ModuleA (A(..), stuffB)"
719773 , "main = print stuffB"
720774 ]
721− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
722776 _ <- waitForDiagnostics
723777 [CACodeAction action@CodeAction { _title = actionTitle }]
724778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -738,14 +792,14 @@ removeImportTests = testGroup "remove import actions"
738792 , "data D = A | B"
739793 , "data E = F"
740794 ]
741− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
742796 let contentB = T.unlines
743797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
744798 , "module ModuleB where"
745799 , "import ModuleA (D(A,B), E(F))"
746800 , "main = B"
747801 ]
748− docB <- openDoc' "ModuleB.hs" "haskell" contentB
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
749803 _ <- waitForDiagnostics
750804 [CACodeAction action@CodeAction { _title = actionTitle }]
751805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -886,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
886940 ]
887941 where
888942 template contentA contentB range expectedAction expectedContentB = do
889− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
890− docB <- openDoc' "ModuleB.hs" "haskell" contentB
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
891945 _ <- waitForDiagnostics
892946 CACodeAction action@CodeAction { _title = actionTitle } : _
893947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -901,46 +955,56 @@ suggestImportTests :: TestTree
901955suggestImportTests = testGroup "suggest import actions"
902956 [ testGroup "Dont want suggestion"
903957 [ -- extend import
904− test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
905959 -- data constructor
906− , test False [] "f = First" [] "import Data.Monoid (First)"
960+ , test False [] "f = First" [] "import Data.Monoid (First)"
907961 -- internal module
908962 , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963+ -- package not in scope
964+ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
909965 ]
910966 , testGroup "want suggestion"
911967 [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
912− , test True [] "f = (:|)" [] "import GHC.Base (NonEmpty((:|)))"
913− , test True [] "f :: Natural" ["f = undefined"] "import GHC.Natural (Natural)"
914− , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import GHC.Base (NonEmpty)"
968+ , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969+ , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970+ , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
915971 , test True [] "f = First" [] "import Data.Monoid (First(First))"
972+ , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973+ , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974+ , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975+ , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
916976 , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
917− , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import GHC.Base (Alternative)"
918− , test True [] "f = empty" [] "import GHC.Base (Alternative(empty))"
977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
919979 , test True [] "f = (&)" [] "import Data.Function ((&))"
920980 , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
921− , expectFailBecause "known broken - reexported name" $
922− 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)"
982+ , test True [] "f = pack" [] "import Data.Text (pack)"
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 ((&))"
923986 ]
924987 ]
925988 where
926− test wanted imps def other newImp = testSession (T.unpack def) $ do
989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
927990 let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
928991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
929− doc <- openDoc' "Test.hs" "haskell" before
930− -- load another module in the session to exercise the package cache
931− _ <- openDoc' "Other.hs" "haskell" after
992+ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993+ liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994+ doc <- createDoc "Test.hs" "haskell" before
932995 _diags <- waitForDiagnostics
933996 let defLine = length imps + 1
934997 range = Range (Position defLine 0) (Position defLine maxBound)
935998 actions <- getCodeActions doc range
936− case wanted of
937− False ->
938− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
939− True -> do
940− action <- liftIO $ pickActionWithTitle newImp actions
941− executeCodeAction action
942− contentAfterAction <- documentContents doc
943− 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+
9441008
9451009addExtensionTests :: TestTree
9461010addExtensionTests = testGroup "add language extension actions"
@@ -987,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
9871051 ]
9881052 where
9891053 template initialContent range expectedAction expectedContents = do
990− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
9911055 _ <- waitForDiagnostics
9921056 CACodeAction action@CodeAction { _title = actionTitle } : _
9931057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1010,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10101074 [""
10111075 ,"someOtherCode = ()"
10121076 ]
1013− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10141078 _ <- waitForDiagnostics
10151079 CACodeAction action@CodeAction { _title = actionTitle } : _
10161080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1034,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
10341098 [""
10351099 ,"someOtherCode = ()"
10361100 ]
1037− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
10381102 _ <- waitForDiagnostics
10391103 CACodeAction action@CodeAction { _title = actionTitle } : _
10401104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1073,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
10731137 ]
10741138 where
10751139 template contentA contentB range expectedAction expectedContentB = do
1076− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1077− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
10781142 _diags <- waitForDiagnostics
10791143 CACodeAction action@CodeAction { _title = actionTitle } : _
10801144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1093,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
10931157 [ "module Testing where"
10941158 , "import Data.Mape"
10951159 ]
1096− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
10971161 _ <- waitForDiagnostics
10981162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
10991163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1130,7 +1194,7 @@ fillTypedHoleTests = let
11301194 newA newB newC = testSession (T.unpack actionTitle) $ do
11311195 let originalCode = sourceCode oldA oldB oldC
11321196 let expectedCode = sourceCode newA newB newC
1133− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
11341198 _ <- waitForDiagnostics
11351199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
11361200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1178,7 +1242,7 @@ addSigActionTests = let
11781242 def >:: sig = testSession (T.unpack def) $ do
11791243 let originalCode = before def
11801244 let expectedCode = after' def sig
1181− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
11821246 _ <- waitForDiagnostics
11831247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
11841248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1210,7 +1274,7 @@ addSigLensesTests = let
12101274 sigSession withMissing def sig = testSession (T.unpack def) $ do
12111275 let originalCode = before withMissing def
12121276 let expectedCode = after' withMissing def sig
1213− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
12141278 [CodeLens {_command = Just c}] <- getCodeLenses doc
12151279 executeCommand c
12161280 modifiedCode <- getDocumentEdit doc
@@ -1232,24 +1296,19 @@ addSigLensesTests = let
12321296 ]
12331297 ]
12341298
1235−findDefinitionAndHoverTests :: TestTree
1236−findDefinitionAndHoverTests = let
1237−
1238− tst (get, check) pos targetRange title = testSession title $ do
1239− doc <- openTestDataDoc sourceFilePath
1240− found <- get doc pos
1241− check found targetRange
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
12421301
1243− checkDefs :: [Location] -> [Expect] -> Session ()
1244− checkDefs defs expectations = traverse_ check expectations where
1245−
1246− check (ExpectRange expectedRange) = do
1247− assertNDefinitionsFound 1 defs
1248− assertRangeCorrect (head defs) expectedRange
1249− check ExpectNoDefinitions = do
1250− assertNDefinitionsFound 0 defs
1251− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1252− 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
12531312
12541313 assertNDefinitionsFound :: Int -> [a] -> Session ()
12551314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1257,8 +1316,19 @@ findDefinitionAndHoverTests = let
12571316 assertRangeCorrect Location{_range = foundRange} expectedRange =
12581317 liftIO $ expectedRange @=? foundRange
12591318
1260− checkHover :: Maybe Hover -> [Expect] -> Session ()
1261− checkHover hover expectations = traverse_ check expectations where
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+
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331+ checkHover hover expectations = traverse_ check =<< expectations where
12621332
12631333 check expected =
12641334 case hover of
@@ -1301,9 +1371,12 @@ findDefinitionAndHoverTests = let
13011371
13021372 mkFindTests tests = testGroup "get"
13031373 [ testGroup "definition" $ mapMaybe fst tests
1304− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
13051376
1306− test runDef runHover look expect title =
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1378+
1379+ testM runDef runHover look expect title =
13071380 ( runDef $ tst def look expect title
13081381 , runHover $ tst hover look expect title ) where
13091382 def = (getDefinitions, checkDefs)
@@ -1311,87 +1384,100 @@ findDefinitionAndHoverTests = let
13111384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
13121385
13131386 -- search locations expectations on results
1314− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1315− fffL8 = Position 8 4 ;
1316− fffL14 = Position 14 7 ;
1317− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1318− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1319− dcL12 = Position 12 11 ;
1320− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1321− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1322− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1323− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1324− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1325− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1326− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1327− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1328− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1329− clL25 = Position 25 9
1330− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1331− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1332− dnbL30 = Position 30 23
1333− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1334− lclL33 = Position 33 22
1335− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1336− mclL37 = Position 37 1
1337− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1338− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1388+ fffL8 = Position 12 4 ;
1389+ fffL14 = Position 18 7 ;
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1392+ dcL12 = Position 16 11 ;
1393+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1394+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1400+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1401+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1402+ clL25 = Position 29 9
1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1405+ dnbL30 = Position 34 23
1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1407+ lclL33 = Position 37 22
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409+ mclL37 = Position 41 1
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
13391412 ; constr = [ExpectHoverText ["Monad m"]]
1340− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1341− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1342− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1343− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1344− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1345− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1346− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1347− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1348− innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421+ innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422+ imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423+ reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
13491424 in
13501425 mkFindTests
1351− -- def hover look expect
1352− [ test yes yes fffL4 fff "field in record definition"
1353− , test broken broken fffL8 fff "field in record construction #71"
1354− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1355− , test yes yes aaaL14 aaa "top-level name" -- 120
1356− , test yes yes dcL7 tcDC "data constructor record #247"
1357− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1358− , test yes yes tcL6 tcData "type constructor #248" -- 147
1359− , test broken yes xtcL5 xtc "type constructor external #248,249"
1360− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1361− , test yes yes vvL16 vv "plain parameter" -- 120
1362− , test yes yes aL18 apmp "pattern match name" -- 120
1363− , test yes yes opL16 op "top-level operator" -- 120, 123
1364− , test yes yes opL18 opp "parameter operator" -- 120
1365− , test yes yes b'L19 bp "name in backticks" -- 120
1366− , test yes yes clL23 cls "class in instance declaration #250"
1367− , test yes yes clL25 cls "class in signature #250" -- 147
1368− , test broken yes eclL15 ecls "external class in signature #249,250"
1369− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1370− , test yes yes dnbL30 dnb "do-notation lookup"
1371− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1372− , test yes yes lclL33 lcb "listcomp lookup"
1373− , test yes yes mclL36 mcl "top-level fn 1st clause"
1374− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1375− , test yes yes spaceL37 space "top-level fn on space #315"
1376− , test no broken docL41 doc "documentation #7"
1377− , test no yes eitL40 kindE "kind of Either #273"
1378− , test no yes intL40 kindI "kind of Int #273"
1379− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1380− , test no yes intL41 litI "literal Int in hover info #274"
1381− , test no yes chrL36 litC "literal Char in hover info #274"
1382− , test no yes txtL8 litT "literal Text in hover info #274"
1383− , test no yes lstL43 litL "literal List in hover info #274"
1384− , test no yes docL41 constr "type constraint in hover info #283"
1385− , test broken broken outL45 outSig "top-level signature #310"
1386− , test broken broken innL48 innSig "inner signature #310"
1426+ -- def hover look expect
1427+ [ test yes yes fffL4 fff "field in record definition"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1429+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1451+ , test no broken docL41 doc "documentation #7"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1461+ , test broken broken innL48 innSig "inner signature #310"
1462+ , testM yes yes imported importedSig "Imported symbol"
1463+ , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
13871464 ]
13881465 where yes, broken :: (TestTree -> Maybe TestTree)
13891466 yes = Just -- test should run and pass
13901467 broken = Just . (`xfail` "known broken")
13911468 no = const Nothing -- don't run this test at all
13921469
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+
13931478pluginTests :: TestTree
1394−pluginTests = testSessionWait "plugins" $ do
1479+pluginTests = (`xfail8101` "known broken (#556)")
1480+ $ testSessionWait "plugins" $ do
13951481 let content =
13961482 T.unlines
13971483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1405,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
14051491 , "foo :: Int -> Int -> Int"
14061492 , "foo a b = a + c"
14071493 ]
1408− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
14091495 expectDiagnostics
14101496 [ ( "Testing.hs",
14111497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1432,7 +1518,7 @@ cppTests =
14321518 run $ expectError content (2, 1)
14331519 )
14341520 , testSessionWait "cpp-ghcide" $ do
1435− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
14361522 ["{-# LANGUAGE CPP #-}"
14371523 ,"main ="
14381524 ,"#ifdef __GHCIDE__"
@@ -1446,7 +1532,7 @@ cppTests =
14461532 where
14471533 expectError :: T.Text -> Cursor -> Session ()
14481534 expectError content cursor = do
1449− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
14501536 expectDiagnostics
14511537 [ ( "Testing.hs",
14521538 [(DsError, cursor, "error: unterminated")]
@@ -1462,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
14621548 , "module Testing where"
14631549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
14641550 ]
1465− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
14661552 expectDiagnostics
14671553 [ ( "Testing.hs",
14681554 [(DsError, (2, 8), "Variable not in scope: z")]
14691555 )
14701556 ]
14711557
1558+
1559+safeTests :: TestTree
1560+safeTests =
1561+ testGroup
1562+ "SafeHaskell"
1563+ [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564+ testSessionWait "load" $ do
1565+ let sourceA =
1566+ T.unlines
1567+ ["{-# LANGUAGE Trustworthy #-}"
1568+ ,"module A where"
1569+ ,"import System.IO.Unsafe"
1570+ ,"import System.IO"
1571+ ,"trustWorthyId :: a -> a"
1572+ ,"trustWorthyId i = unsafePerformIO $ do"
1573+ ," putStrLn \"I'm safe\""
1574+ ," return i"]
1575+ sourceB =
1576+ T.unlines
1577+ ["{-# LANGUAGE Safe #-}"
1578+ ,"module B where"
1579+ ,"import A"
1580+ ,"safeId :: a -> a"
1581+ ,"safeId = trustWorthyId"
1582+ ]
1583+
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
1586+ expectNoMoreDiagnostics 1 ]
1587+
14721588thTests :: TestTree
14731589thTests =
14741590 testGroup
@@ -1494,8 +1610,8 @@ thTests =
14941610 "b :: Integer",
14951611 "b = $(litE $ IntegerL $ a) + n"
14961612 ]
1497− _ <- openDoc' "A.hs" "haskell" sourceA
1498− _ <- openDoc' "B.hs" "haskell" sourceB
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1614+ _ <- createDoc "B.hs" "haskell" sourceB
14991615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
15001616 , testSessionWait "newtype-closure" $ do
15011617 let sourceA =
@@ -1515,8 +1631,8 @@ thTests =
15151631 ,"import A"
15161632 ,"b :: Int"
15171633 ,"b = $( a )" ]
1518− _ <- openDoc' "A.hs" "haskell" sourceA
1519− _ <- openDoc' "B.hs" "haskell" sourceB
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
15201636 return ()
15211637 ]
15221638
@@ -1525,7 +1641,7 @@ completionTests
15251641 = testGroup "completion"
15261642 [ testSessionWait "variable" $ do
15271643 let source = T.unlines ["module A where", "f = hea"]
1528− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
15291645 compls <- getCompletions docId (Position 1 7)
15301646 liftIO $ map dropDocs compls @?=
15311647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1537,7 +1653,7 @@ completionTests
15371653 ]
15381654 , testSessionWait "constructor" $ do
15391655 let source = T.unlines ["module A where", "f = Tru"]
1540− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
15411657 compls <- getCompletions docId (Position 1 7)
15421658 liftIO $ map dropDocs compls @?=
15431659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1549,7 +1665,7 @@ completionTests
15491665 ]
15501666 , testSessionWait "type" $ do
15511667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1552− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
15531669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
15541670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
15551671 compls <- getCompletions docId (Position 2 7)
@@ -1566,7 +1682,7 @@ completionTests
15661682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
15671683 , testSessionWait "qualified" $ do
15681684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1569− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
15701686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
15711687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
15721688 compls <- getCompletions docId (Position 2 15)
@@ -1580,9 +1696,30 @@ completionTests
15801696 ]
15811697 , testSessionWait "keyword" $ do
15821698 let source = T.unlines ["module A where", "f = newty"]
1583− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
15841700 compls <- getCompletions docId (Position 1 9)
15851701 liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1706+ , "f = f"
1707+ ]
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710+ changeDoc docId
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
1714+ , "f = f"
1715+ , "g :: Intege"
1716+ ]
1717+ ]
1718+ -- At this point the module parses but does not typecheck.
1719+ -- This should be sufficient to detect that we are in a
1720+ -- type context and only show the completion to the type.
1721+ compls <- getCompletions docId (Position 3 11)
1722+ liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
15861723 ]
15871724 where
15881725 dropDocs :: CompletionItem -> CompletionItem
@@ -1590,6 +1727,7 @@ completionTests
15901727 complItem label kind ty = CompletionItem
15911728 { _label = label
15921729 , _kind = kind
1730+ , _tags = List []
15931731 , _detail = (":: " <>) <$> ty
15941732 , _documentation = Nothing
15951733 , _deprecated = Nothing
@@ -1607,6 +1745,7 @@ completionTests
16071745 keywordItem label = CompletionItem
16081746 { _label = label
16091747 , _kind = Just CiKeyword
1748+ , _tags = List []
16101749 , _detail = Nothing
16111750 , _documentation = Nothing
16121751 , _deprecated = Nothing
@@ -1634,7 +1773,7 @@ outlineTests = testGroup
16341773 "outline"
16351774 [ testSessionWait "type class" $ do
16361775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1637− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
16381777 symbols <- getDocumentSymbols docId
16391778 liftIO $ symbols @?= Left
16401779 [ moduleSymbol
@@ -1647,7 +1786,7 @@ outlineTests = testGroup
16471786 ]
16481787 , testSessionWait "type class instance " $ do
16491788 let source = T.unlines ["class A a where", "instance A () where"]
1650− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
16511790 symbols <- getDocumentSymbols docId
16521791 liftIO $ symbols @?= Left
16531792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1655,7 +1794,7 @@ outlineTests = testGroup
16551794 ]
16561795 , testSessionWait "type family" $ do
16571796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1658− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
16591798 symbols <- getDocumentSymbols docId
16601799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
16611800 , testSessionWait "type family instance " $ do
@@ -1664,7 +1803,7 @@ outlineTests = testGroup
16641803 , "type family A a"
16651804 , "type instance A () = ()"
16661805 ]
1667− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
16681807 symbols <- getDocumentSymbols docId
16691808 liftIO $ symbols @?= Left
16701809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1672,7 +1811,7 @@ outlineTests = testGroup
16721811 ]
16731812 , testSessionWait "data family" $ do
16741813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1675− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
16761815 symbols <- getDocumentSymbols docId
16771816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
16781817 , testSessionWait "data family instance " $ do
@@ -1681,7 +1820,7 @@ outlineTests = testGroup
16811820 , "data family A a"
16821821 , "data instance A () = A ()"
16831822 ]
1684− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
16851824 symbols <- getDocumentSymbols docId
16861825 liftIO $ symbols @?= Left
16871826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1689,36 +1828,36 @@ outlineTests = testGroup
16891828 ]
16901829 , testSessionWait "constant" $ do
16911830 let source = T.unlines ["a = ()"]
1692− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
16931832 symbols <- getDocumentSymbols docId
16941833 liftIO $ symbols @?= Left
16951834 [docSymbol "a" SkFunction (R 0 0 0 6)]
16961835 , testSessionWait "pattern" $ do
16971836 let source = T.unlines ["Just foo = Just 21"]
1698− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
16991838 symbols <- getDocumentSymbols docId
17001839 liftIO $ symbols @?= Left
17011840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
17021841 , testSessionWait "pattern with type signature" $ do
17031842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1704− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
17051844 symbols <- getDocumentSymbols docId
17061845 liftIO $ symbols @?= Left
17071846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
17081847 , testSessionWait "function" $ do
17091848 let source = T.unlines ["a x = ()"]
1710− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
17111850 symbols <- getDocumentSymbols docId
17121851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
17131852 , testSessionWait "type synonym" $ do
17141853 let source = T.unlines ["type A = Bool"]
1715− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
17161855 symbols <- getDocumentSymbols docId
17171856 liftIO $ symbols @?= Left
17181857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
17191858 , testSessionWait "datatype" $ do
17201859 let source = T.unlines ["data A = C"]
1721− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
17221861 symbols <- getDocumentSymbols docId
17231862 liftIO $ symbols @?= Left
17241863 [ docSymbolWithChildren "A"
@@ -1726,9 +1865,21 @@ outlineTests = testGroup
17261865 (R 0 0 0 10)
17271866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
17281867 ]
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+ ]
17291880 , testSessionWait "import" $ do
17301881 let source = T.unlines ["import Data.Maybe"]
1731− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
17321883 symbols <- getDocumentSymbols docId
17331884 liftIO $ symbols @?= Left
17341885 [docSymbolWithChildren "imports"
@@ -1739,7 +1890,7 @@ outlineTests = testGroup
17391890 ]
17401891 , testSessionWait "multiple import" $ do
17411892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1742− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
17431894 symbols <- getDocumentSymbols docId
17441895 liftIO $ symbols @?= Left
17451896 [docSymbolWithChildren "imports"
@@ -1754,7 +1905,7 @@ outlineTests = testGroup
17541905 [ "{-# language ForeignFunctionInterface #-}"
17551906 , "foreign import ccall \"a\" a :: Int"
17561907 ]
1757− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
17581909 symbols <- getDocumentSymbols docId
17591910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
17601911 , testSessionWait "foreign export" $ do
@@ -1762,7 +1913,7 @@ outlineTests = testGroup
17621913 [ "{-# language ForeignFunctionInterface #-}"
17631914 , "foreign export ccall odd :: Int -> Bool"
17641915 ]
1765− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
17661917 symbols <- getDocumentSymbols docId
17671918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
17681919 ]
@@ -1775,6 +1926,8 @@ outlineTests = testGroup
17751926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
17761927 docSymbolWithChildren name kind loc cc =
17771928 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)
17781931 moduleSymbol name loc cc = DocumentSymbol name
17791932 Nothing
17801933 SkFile
@@ -1796,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
17961949xfail :: TestTree -> String -> TestTree
17971950xfail = flip expectFailBecause
17981951
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+
17991959data Expect
18001960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
18011962-- | ExpectDefRange Range -- Only gotoDef should report this range
18021963 | ExpectHoverRange Range -- Only hover should report this range
18031964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1810,6 +1971,9 @@ data Expect
18101971mkR :: Int -> Int -> Int -> Int -> Expect
18111972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
18121973
1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976+
18131977haddockTests :: TestTree
18141978haddockTests
18151979 = testGroup "haddock"
@@ -1869,6 +2033,7 @@ cradleTests :: TestTree
18692033cradleTests = testGroup "cradle"
18702034 [testGroup "dependencies" [sessionDepsArePickedUp]
18712035 ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
18722037 ]
18732038
18742039loadCradleOnlyonce :: TestTree
@@ -1883,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"
18832048 test dir
18842049 implicit dir = test dir
18852050 test _dir = do
1886− doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
18872052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
18882053 liftIO $ length msgs @?= 1
18892054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
18902055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
18912056 liftIO $ length msgs @?= 0
1892− _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
18932058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
18942059 liftIO $ length msgs @?= 0
18952060
18962061
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+
18972098cradleLoadedMessage :: Session FromServerMessage
18982099cradleLoadedMessage = satisfy $ \case
18992100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -1902,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case
19022103cradleLoadedMethod :: T.Text
19032104cradleLoadedMethod = "ghcide/cradle/loaded"
19042105
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+
19052156sessionDepsArePickedUp :: TestTree
19062157sessionDepsArePickedUp = testSession'
19072158 "session-deps-are-picked-up"
@@ -1911,7 +2162,7 @@ sessionDepsArePickedUp = testSession'
19112162 (dir </> "hie.yaml")
19122163 "cradle: {direct: {arguments: []}}"
19132164 -- Open without OverloadedStrings and expect an error.
1914− doc <- openDoc' "Foo.hs" "haskell" fooContent
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
19152166 expectDiagnostics
19162167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
19172168 -- Update hie.yaml to enable OverloadedStrings.
@@ -1946,6 +2197,9 @@ sessionDepsArePickedUp = testSession'
19462197testSession :: String -> Session () -> TestTree
19472198testSession name = testCase name . run
19482199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
19492203testSession' :: String -> (FilePath -> Session ()) -> TestTree
19502204testSession' name = testCase name . run'
19512205
@@ -1980,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)
19802234run :: Session a -> IO a
19812235run s = withTempDir $ \dir -> runInDir dir s
19822236
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+
19832250run' :: (FilePath -> Session a) -> IO a
19842251run' s = withTempDir $ \dir -> runInDir dir (s dir)
19852252
@@ -1991,6 +2258,7 @@ runInDir dir s = do
19912258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
19922259 createDirectoryIfMissing True $ dir ++ "/Data"
19932260
2261+
19942262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
19952263 -- HIE calls getXgdDirectory which assumes that HOME is set.
19962264 -- Only sets HOME if it wasn't already set.
@@ -2008,7 +2276,7 @@ runInDir dir s = do
20082276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
20092277openTestDataDoc path = do
20102278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2011− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
20122280
20132281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
20142282findCodeActions doc range expectedTitles = do
@@ -2036,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
20362304unitTests :: TestTree
20372305unitTests = do
20382306 testGroup "Unit"
2039− [ testCase "empty file path" $
2040− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
2308+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309+ , testCase "empty file path works using toNormalizedFilePath'" $
2310+ uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311+ , testCase "empty path URI" $ do
2312+ Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313+ uriScheme @?= "file:"
2314+ uriPath @?= ""
2315+ , testCase "from empty path URI" $ do
2316+ let uri = Uri "file://"
2317+ uriToFilePath' uri @?= Just ""
20412318 ]
20422319
2043−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2044−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2045−openDoc' fp name contents = do
2046− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2047− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2048− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2049− return res
2050−
2051−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2052−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2053−-- At the moment this is just LSPTest.openDoc' but it may change in the future
2054−-- when/if lsp-test implements WatchedFiles
2055−openDoc'' = LSPTest.openDoc'
2056−
20572320positionMappingTests :: TestTree
20582321positionMappingTests =
20592322 testGroup "position mapping"
@@ -2222,3 +2485,12 @@ nthLine i r
22222485 | i == 0 && Rope.rows r == 0 = r
22232486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
22242487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2488+
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490+getWatchedFilesSubscriptionsUntil = do
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2492+ return
2493+ [ args
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2496+ ]