@@ -1,6 +1,7 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
4+{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE CPP #-}
7{-# LANGUAGE CPP #-}
@@ -9,27 +10,32 @@
9module Main (main) where
10module Main (main) where
11import Control.Applicative.Combinators
12import Control.Applicative.Combinators
12−import Control.Exception (catch)
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
13import Control.Monad
15import Control.Monad
14import Control.Monad.IO.Class (liftIO)
16import Control.Monad.IO.Class (liftIO)
15−import Data.Char (toLower)
17+import Data.Aeson (FromJSON, Value)
16import Data.Foldable
18import Data.Foldable
17−import Data.List
19+import Data.List.Extra
18import Data.Rope.UTF16 (Rope)
20import Data.Rope.UTF16 (Rope)
19import qualified Data.Rope.UTF16 as Rope
21import qualified Data.Rope.UTF16 as Rope
20import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
22import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
21import Development.IDE.GHC.Util
23import Development.IDE.GHC.Util
22import qualified Data.Text as T
24import qualified Data.Text as T
23import Development.IDE.Spans.Common
26import Development.IDE.Spans.Common
24import Development.IDE.Test
27import Development.IDE.Test
25import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
26import Development.IDE.Types.Location
29import Development.IDE.Types.Location
27−import qualified Language.Haskell.LSP.Test as LSPTest
30+import Development.Shake (getDirectoryFilesIO)
28−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
29import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
30import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
31import Language.Haskell.LSP.VFS (applyChange)
36import Language.Haskell.LSP.VFS (applyChange)
32−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
33import System.FilePath
39import System.FilePath
34import System.IO.Extra
40import System.IO.Extra
35import System.Directory
41import System.Directory
@@ -37,34 +43,41 @@ import Test.QuickCheck
37import Test.QuickCheck.Instances ()
43import Test.QuickCheck.Instances ()
38import Test.Tasty
44import Test.Tasty
39import Test.Tasty.ExpectedFailure
45import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
40import Test.Tasty.HUnit
47import Test.Tasty.HUnit
41import Test.Tasty.QuickCheck
48import Test.Tasty.QuickCheck
42import Data.Maybe
49import Data.Maybe
44main :: IO ()
51main :: IO ()
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
45−main = defaultMain $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
46− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
47− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
48− void (message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
49− void (message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
50− closeDoc doc
60+ closeDoc doc
51− void (message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
52− , initializeResponseTests
62+ , initializeResponseTests
53− , completionTests
63+ , completionTests
54− , cppTests
64+ , cppTests
55− , diagnosticTests
65+ , diagnosticTests
56− , codeActionTests
66+ , codeActionTests
57− , codeLensesTests
67+ , codeLensesTests
58− , outlineTests
68+ , outlineTests
59− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
60− , pluginTests
70+ , pluginTests
61− , preprocessorTests
71+ , preprocessorTests
62− , thTests
72+ , thTests
63− , unitTests
74+ , unitTests
64− , haddockTests
75+ , haddockTests
65− , positionMappingTests
76+ , positionMappingTests
66− , watchedFilesTests
77+ , watchedFilesTests
69initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
70initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -99,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where
99 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
100 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
101 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
102− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
103 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
104 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
@@ -115,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where
115 chk title getActual expected =
128 chk title getActual expected =
116 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
131+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132+ che title getActual _expected = testCase title doTest
135+ ir <- getInitializeResponse
136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137+ True @=? T.isSuffixOf "typesignature.add" command
118 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
119− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
120 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
122 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -130,7 +152,7 @@ diagnosticTests :: TestTree
130diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
131 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
132 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
133− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
134 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
135 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
136 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -141,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"
141 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
142 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
143 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
144− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
145− void (message :: Session WorkDoneProgressCreateRequest)
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
146− void (message :: Session WorkDoneProgressBeginNotification)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
147 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
148 { _range = Just (Range (Position 0 15) (Position 0 18))
170 { _range = Just (Range (Position 0 15) (Position 0 18))
149 , _rangeLength = Nothing
171 , _rangeLength = Nothing
@@ -159,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
159 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
160 , "bar a b = cd + b"
182 , "bar a b = cd + b"
162− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
163 expectDiagnostics
185 expectDiagnostics
164 [ ( "Testing.hs"
186 [ ( "Testing.hs"
165 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -173,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
173 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
174 , "foo a b = a + b"
196 , "foo a b = a + b"
176− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
177 expectDiagnostics
199 expectDiagnostics
178 [ ( "Testing.hs"
200 [ ( "Testing.hs"
179 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -185,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
185 , "foo :: Int -> String"
207 , "foo :: Int -> String"
186 , "foo a = _ a"
208 , "foo a = _ a"
188− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
189 expectDiagnostics
211 expectDiagnostics
190 [ ( "Testing.hs"
212 [ ( "Testing.hs"
191 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -207,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
207 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
208 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
209 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
210− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
211− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
212 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
214 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
215 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
216 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
217− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
220 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
221 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
222− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
223 let contentB = T.unlines
244 let contentB = T.unlines
224 [ "module ModuleB where"
245 [ "module ModuleB where"
225 , "import ModuleA"
246 , "import ModuleA"
227− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
228 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
229 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
230 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -237,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
237 [ "module ModuleB where"
258 [ "module ModuleB where"
238 , "import ModuleA"
259 , "import ModuleA"
240− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
241 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
242 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
243− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
244 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
245 , testSessionWait "add missing module (non workspace)" $ do
266 , testSessionWait "add missing module (non workspace)" $ do
246 let contentB = T.unlines
267 let contentB = T.unlines
247 [ "module ModuleB where"
268 [ "module ModuleB where"
248 , "import ModuleA"
269 , "import ModuleA"
250− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
251 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
252 let contentA = T.unlines [ "module ModuleA where" ]
273 let contentA = T.unlines [ "module ModuleA where" ]
253− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
254 expectDiagnostics [("/tmp/ModuleB.hs", [])]
275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
255 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
256 let contentA = T.unlines
277 let contentA = T.unlines
@@ -261,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
261 [ "module ModuleB where"
282 [ "module ModuleB where"
262 , "import ModuleA"
283 , "import ModuleA"
264− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
265− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
266 expectDiagnostics
287 expectDiagnostics
267 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
268 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -283,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
283 let contentBboot = T.unlines
304 let contentBboot = T.unlines
284 [ "module ModuleB where"
305 [ "module ModuleB where"
286− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
287− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
288− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
289 expectDiagnostics []
310 expectDiagnostics []
290 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
291 let contentB = T.unlines
312 let contentB = T.unlines
@@ -307,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
307 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
308 , "y = x"
329 , "y = x"
310− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
311− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
312− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
313− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
314 expectDiagnostics []
335 expectDiagnostics []
315 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
316 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -319,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
319 , "module ModuleB where"
340 , "module ModuleB where"
320 , "import ModuleA"
341 , "import ModuleA"
322− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
323− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
324 expectDiagnostics
345 expectDiagnostics
325 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
326 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -342,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
342 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
343 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
345− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
346− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
347 expectDiagnostics
368 expectDiagnostics
348 [ ( "Main.hs"
369 [ ( "Main.hs"
349 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -358,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
358 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
359 , "foo a = 1"
380 , "foo a = 1"
361− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
362 expectDiagnostics
383 expectDiagnostics
363 [ ( "Foo.hs"
384 [ ( "Foo.hs"
364 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -383,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
383 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
384 uriB <- pure $
405 uriB <- pure $
385 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
386− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
387 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
388 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
389 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
390 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
391 uriA <- pure $
412 uriA <- pure $
392 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
393− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
394 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
395 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
396 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
397− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
398 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
399 -- Check that if we put a lower-case drive in for A.A
420 -- Check that if we put a lower-case drive in for A.A
400 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -403,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
403 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
404 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
405 closeDoc a
426 closeDoc a
427+ , testSessionWait "haddock parse error" $ do
428+ let fooContent = T.unlines
429+ [ "module Foo where"
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
436+ , [(DsError, (2, 8), "Parse error on input")
440+ , testSessionWait "strip file path" $ do
444+ [ "module " <> name <> " where"
445+ , "value :: Maybe ()"
448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449+ notification <- skipManyTill anyMessage diagnostic
456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458+ Lens.mapMOf_ offenders failure notification
408codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -411,6 +464,7 @@ codeActionTests = testGroup "code actions"
411 , typeWildCardActionTests
464 , typeWildCardActionTests
412 , removeImportTests
465 , removeImportTests
413 , extendImportTests
466 , extendImportTests
467+ , suggestImportTests
414 , addExtensionTests
468 , addExtensionTests
415 , fixConstructorImportTests
469 , fixConstructorImportTests
416 , importRenameActionTests
470 , importRenameActionTests
@@ -426,21 +480,28 @@ codeLensesTests = testGroup "code lenses"
427watchedFilesTests :: TestTree
481watchedFilesTests :: TestTree
428watchedFilesTests = testGroup "watched files"
482watchedFilesTests = testGroup "watched files"
429− [ testSession "workspace file" $ do
483+ [ testSession' "workspace files" $ \sessionDir -> do
430− _ <- openDoc' "A.hs" "haskell" "module A where"
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
431− RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
432− let watchedFileRegs =
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
433− [ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]
487+
434− liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs
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
435− , testSession "non workspace file" $ do
495+ , testSession' "non workspace file" $ \sessionDir -> do
436− _ <- openDoc' "/tmp/A.hs" "haskell" "module A where"
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
437− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
438− let watchedFileRegs =
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
440− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
441− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
442− ]
502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
443− liftIO $ watchedFileRegs @?= []
503+ liftIO $ length watchedFileRegs @?= 2
444 -- TODO add a test for didChangeWorkspaceFolder
505 -- TODO add a test for didChangeWorkspaceFolder
@@ -452,7 +513,7 @@ renameActionTests = testGroup "rename actions"
452 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
453 , "foo argName = argNme"
514 , "foo argName = argNme"
455− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
456 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
457 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
458 executeCodeAction action
519 executeCodeAction action
@@ -470,7 +531,7 @@ renameActionTests = testGroup "rename actions"
470 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
471 , "foo = maybToList"
532 , "foo = maybToList"
473− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
474 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
475 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
476 executeCodeAction action
537 executeCodeAction action
@@ -488,7 +549,7 @@ renameActionTests = testGroup "rename actions"
488 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
489 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
491− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
492 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
493 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
494 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -500,7 +561,7 @@ renameActionTests = testGroup "rename actions"
500 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
501 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
503− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
504 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
505 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
506 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -523,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
523 , "func :: _"
584 , "func :: _"
524 , "func x = x"
585 , "func x = x"
526− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
527 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
528 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
529 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -543,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
543 , "func :: _"
604 , "func :: _"
544 , "func x y = x + y"
605 , "func x y = x + y"
546− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
547 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
548 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
549 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -566,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
566 , " y = x * 2"
627 , " y = x * 2"
567 , " in y"
628 , " in y"
569− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
570 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
571 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
572 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -591,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
591 let contentA = T.unlines
652 let contentA = T.unlines
592 [ "module ModuleA where"
653 [ "module ModuleA where"
594− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
595 let contentB = T.unlines
656 let contentB = T.unlines
596 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
597 , "module ModuleB where"
658 , "module ModuleB where"
@@ -599,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
599 , "stuffB :: Integer"
660 , "stuffB :: Integer"
600 , "stuffB = 123"
661 , "stuffB = 123"
602− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
603 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
604 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
605 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -617,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
617 let contentA = T.unlines
678 let contentA = T.unlines
618 [ "module ModuleA where"
679 [ "module ModuleA where"
620− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
621 let contentB = T.unlines
682 let contentB = T.unlines
622 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
623 , "module ModuleB where"
684 , "module ModuleB where"
@@ -625,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
625 , "stuffB :: Integer"
686 , "stuffB :: Integer"
626 , "stuffB = 123"
687 , "stuffB = 123"
628− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
629 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
630 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
631 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -647,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
647 , "stuffB = 123"
708 , "stuffB = 123"
648 , "stuffC = ()"
709 , "stuffC = ()"
650− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
651 let contentB = T.unlines
712 let contentB = T.unlines
652 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
653 , "module ModuleB where"
714 , "module ModuleB where"
654 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
655 , "main = print stuffB"
716 , "main = print stuffB"
657− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
658 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
659 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
660 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -668,29 +729,26 @@ removeImportTests = testGroup "remove import actions"
668 , "main = print stuffB"
729 , "main = print stuffB"
670 liftIO $ expectedContentAfterAction @=? contentAfterAction
731 liftIO $ expectedContentAfterAction @=? contentAfterAction
671− , testSession "redundant symbol binding" $ do
732+ , testSession "redundant operator" $ do
672 let contentA = T.unlines
733 let contentA = T.unlines
673 [ "module ModuleA where"
734 [ "module ModuleA where"
674 , "a !! b = a"
735 , "a !! b = a"
675 , "stuffB :: Integer"
737 , "stuffB :: Integer"
676 , "stuffB = 123"
738 , "stuffB = 123"
678− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
679 let contentB = T.unlines
741 let contentB = T.unlines
680 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
681 , "module ModuleB where"
743 , "module ModuleB where"
682− , "import qualified ModuleA as A ((!!), stuffB, (!!))"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
683 , "main = print A.stuffB"
745 , "main = print A.stuffB"
685− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
686 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
687 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
688 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
689−#if MIN_GHC_API_VERSION(8,6,0)
690− liftIO $ "Remove !! from import" @=? actionTitle
692− liftIO $ "Remove A.!! from import" @=? actionTitle
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
694 executeCodeAction action
752 executeCodeAction action
695 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
696 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -700,21 +758,21 @@ removeImportTests = testGroup "remove import actions"
700 , "main = print A.stuffB"
758 , "main = print A.stuffB"
702 liftIO $ expectedContentAfterAction @=? contentAfterAction
760 liftIO $ expectedContentAfterAction @=? contentAfterAction
703− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do
761+ , testSession "redundant all import" $ do
704 let contentA = T.unlines
762 let contentA = T.unlines
705 [ "module ModuleA where"
763 [ "module ModuleA where"
706 , "data A = A"
764 , "data A = A"
707 , "stuffB :: Integer"
765 , "stuffB :: Integer"
708 , "stuffB = 123"
766 , "stuffB = 123"
710− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
711 let contentB = T.unlines
769 let contentB = T.unlines
712 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 , "module ModuleB where"
771 , "module ModuleB where"
714 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
715 , "main = print stuffB"
773 , "main = print stuffB"
717− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
718 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
719 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
720 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -728,6 +786,33 @@ removeImportTests = testGroup "remove import actions"
728 , "main = print stuffB"
786 , "main = print stuffB"
730 liftIO $ expectedContentAfterAction @=? contentAfterAction
788 liftIO $ expectedContentAfterAction @=? contentAfterAction
789+ , testSession "redundant constructor import" $ do
790+ let contentA = T.unlines
791+ [ "module ModuleA where"
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
796+ let contentB = T.unlines
797+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798+ , "module ModuleB where"
799+ , "import ModuleA (D(A,B), E(F))"
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
803+ _ <- waitForDiagnostics
804+ [CACodeAction action@CodeAction { _title = actionTitle }]
805+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
806+ liftIO $ "Remove A, E, F from import" @=? actionTitle
807+ executeCodeAction action
808+ contentAfterAction <- documentContents docB
809+ let expectedContentAfterAction = T.unlines
810+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
811+ , "module ModuleB where"
812+ , "import ModuleA (D(B))"
815+ liftIO $ expectedContentAfterAction @=? contentAfterAction
733extendImportTests :: TestTree
818extendImportTests :: TestTree
@@ -752,6 +837,26 @@ extendImportTests = testGroup "extend import actions"
752 , "import ModuleA as A (stuffA, stuffB)"
837 , "import ModuleA as A (stuffA, stuffB)"
753 , "main = print (stuffA, stuffB)"
838 , "main = print (stuffA, stuffB)"
840+ , testSession "extend single line import with operator" $ template
842+ [ "module ModuleA where"
843+ , "(.*) :: Integer -> Integer -> Integer"
845+ , "stuffB :: Integer"
849+ [ "module ModuleB where"
850+ , "import ModuleA as A (stuffB)"
851+ , "main = print (stuffB .* stuffB)"
853+ (Range (Position 3 17) (Position 3 18))
854+ "Add .* to the import list of ModuleA"
856+ [ "module ModuleB where"
857+ , "import ModuleA as A ((.*), stuffB)"
858+ , "main = print (stuffB .* stuffB)"
755 , testSession "extend single line import with type" $ template
860 , testSession "extend single line import with type" $ template
756 (T.unlines
861 (T.unlines
757 [ "module ModuleA where"
862 [ "module ModuleA where"
@@ -835,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
837 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
838− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
839− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
840 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
841 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
842 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -846,6 +951,61 @@ extendImportTests = testGroup "extend import actions"
846 contentAfterAction <- documentContents docB
951 contentAfterAction <- documentContents docB
847 liftIO $ expectedContentB @=? contentAfterAction
952 liftIO $ expectedContentB @=? contentAfterAction
954+suggestImportTests :: TestTree
955+suggestImportTests = testGroup "suggest import actions"
956+ [ testGroup "Dont want suggestion"
958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
960+ , test False [] "f = First" [] "import Data.Monoid (First)"
962+ , 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)"
966+ , testGroup "want suggestion"
967+ [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (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)"
971+ , 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))"
976+ , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979+ , test True [] "f = (&)" [] "import Data.Function ((&))"
980+ , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
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 ((&))"
989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990+ let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991+ after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
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
995+ _diags <- waitForDiagnostics
996+ let defLine = length imps + 1
997+ range = Range (Position defLine 0) (Position defLine maxBound)
998+ actions <- getCodeActions doc range
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
849addExtensionTests :: TestTree
1009addExtensionTests :: TestTree
850addExtensionTests = testGroup "add language extension actions"
1010addExtensionTests = testGroup "add language extension actions"
851 [ testSession "add NamedFieldPuns language extension" $ template
1011 [ testSession "add NamedFieldPuns language extension" $ template
@@ -891,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
893 template initialContent range expectedAction expectedContents = do
1053 template initialContent range expectedAction expectedContents = do
894− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
895 _ <- waitForDiagnostics
1055 _ <- waitForDiagnostics
896 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 CACodeAction action@CodeAction { _title = actionTitle } : _
897 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -914,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
915 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
917− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
918 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
919 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
920 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -938,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
939 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
941− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
942 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
943 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
944 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -977,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
979 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
980− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
981− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
982 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
983 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
984 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -997,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
997 [ "module Testing where"
1157 [ "module Testing where"
998 , "import Data.Mape"
1158 , "import Data.Mape"
1000− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
1001 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
1002 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1003 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1034,10 +1194,10 @@ fillTypedHoleTests = let
1034 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
1035 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
1036 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
1037− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
1038 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
1039 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1040− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1041 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
1042 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
1043 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -1074,36 +1234,37 @@ fillTypedHoleTests = let
1075addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
1076addSigActionTests = let
1236addSigActionTests = let
1077− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
1078− moduleH = "module Sigs where"
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1079 before def = T.unlines [header, moduleH, def]
1239 before def = T.unlines [header, moduleH, def]
1080 after' def sig = T.unlines [header, moduleH, sig, def]
1240 after' def sig = T.unlines [header, moduleH, sig, def]
1082 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
1083 let originalCode = before def
1243 let originalCode = before def
1084 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
1085− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1086 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
1087 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1088− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1089 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
1090 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
1091 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
1093 testGroup "add signature"
1253 testGroup "add signature"
1094− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
1095− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1096− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1256+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1097− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1098− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1099− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1102addSigLensesTests :: TestTree
1263addSigLensesTests :: TestTree
1103addSigLensesTests = let
1264addSigLensesTests = let
1104− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1105 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1106− moduleH = "module Sigs where"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1107 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1108 before withMissing def
1269 before withMissing def
1109 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
@@ -1113,49 +1274,41 @@ addSigLensesTests = let
1113 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1114 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1115 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1116− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1117 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1118 executeCommand c
1279 executeCommand c
1119 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
1120 liftIO $ expectedCode @=? modifiedCode
1281 liftIO $ expectedCode @=? modifiedCode
1122 testGroup "add signature"
1283 testGroup "add signature"
1123− [ testGroup "with warnings enabled"
1284+ [ testGroup title
1124− [ sigSession True "abc = True" "abc :: Bool"
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1125− , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"
1286+ , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1126− , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1287+ , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1127− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1128− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1129− , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1130− ]
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1131− , testGroup "with warnings disabled"
1132− [ sigSession False "abc = True" "abc :: Bool"
1133− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"
1134− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1135− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1136− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1137− , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1293+ | (title, enableWarnings) <-
1294+ [("with warnings enabled", True)
1295+ ,("with warnings disabled", False)
1141−findDefinitionAndHoverTests :: TestTree
1142−findDefinitionAndHoverTests = let
1144− tst (get, check) pos targetRange title = testSession title $ do
1145− doc <- openTestDataDoc sourceFilePath
1146− found <- get doc pos
1147− check found targetRange
1149− checkDefs :: [Location] -> [Expect] -> Session ()
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1150− checkDefs defs expectations = traverse_ check expectations where
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1152− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1153− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1154− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1155− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1156− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1157− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1158− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1160 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1161 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1163,8 +1316,19 @@ findDefinitionAndHoverTests = let
1163 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1164 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1166− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1167− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1169 check expected =
1333 check expected =
1170 case hover of
1334 case hover of
@@ -1207,9 +1371,12 @@ findDefinitionAndHoverTests = let
1208 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1209 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1210− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1212− test runDef runHover look expect title =
1379+ testM runDef runHover look expect title =
1213 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1214 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1215 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1217,87 +1384,100 @@ findDefinitionAndHoverTests = let
1217 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1219 -- search locations expectations on results
1386 -- search locations expectations on results
1220− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1221− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1222− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1223− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1224− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1225− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1226− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1393+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1227− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1394+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1228− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1229− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1230− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1231− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1232− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1233− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1400+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1234− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1401+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1235− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1236− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1237− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1238− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1239− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1240− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1241− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1242− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1243− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1244− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1245 ; constr = [ExpectHoverText ["Monad m"]]
1412 ; constr = [ExpectHoverText ["Monad m"]]
1246− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1247− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1248− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1249− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1250− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1251− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1252− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1253− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1420+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1254− innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
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]
1256 mkFindTests
1425 mkFindTests
1257− -- def hover look expect
1426+ -- def hover look expect
1258− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1259− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1260− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1429+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1261− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1262− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1263− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1264− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1265− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1266− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1267− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1268− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1269− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1270− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1271− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1272− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1273− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1274− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1275− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1276− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1277− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1278− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1279− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1280− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1281− , test yes yes spaceL37 space "top-level fn on space #315"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1282− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1283− , test no yes eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1284− , test no yes intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1285− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1286− , test no yes intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1287− , test no yes chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1288− , test no yes txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1289− , test no yes lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1290− , test no yes docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1291− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1292− , test broken broken innL48 innSig "inner 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)"
1294 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1295 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1296 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1297 no = const Nothing -- don't run this test at all
1468 no = const Nothing -- don't run this test at all
1470+checkFileCompiles :: FilePath -> TestTree
1471+checkFileCompiles fp =
1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473+ void (openTestDataDoc (dir </> fp))
1474+ expectNoMoreDiagnostics 0.5
1299pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1300−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1301 let content =
1481 let content =
1302 T.unlines
1482 T.unlines
1303 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1311,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1311 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1312 , "foo a b = a + c"
1492 , "foo a b = a + c"
1314− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1315 expectDiagnostics
1495 expectDiagnostics
1316 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1317 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1338,7 +1518,7 @@ cppTests =
1338 run $ expectError content (2, 1)
1518 run $ expectError content (2, 1)
1340 , testSessionWait "cpp-ghcide" $ do
1520 , testSessionWait "cpp-ghcide" $ do
1341− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1342 ["{-# LANGUAGE CPP #-}"
1522 ["{-# LANGUAGE CPP #-}"
1343 ,"main ="
1523 ,"main ="
1344 ,"#ifdef __GHCIDE__"
1524 ,"#ifdef __GHCIDE__"
@@ -1352,7 +1532,7 @@ cppTests =
1353 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1354 expectError content cursor = do
1534 expectError content cursor = do
1355− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1356 expectDiagnostics
1536 expectDiagnostics
1357 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1358 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1368,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1368 , "module Testing where"
1548 , "module Testing where"
1369 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1371− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1372 expectDiagnostics
1552 expectDiagnostics
1373 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1374 [(DsError, (2, 8), "Variable not in scope: z")]
1554 [(DsError, (2, 8), "Variable not in scope: z")]
1559+safeTests :: TestTree
1563+ [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564+ testSessionWait "load" $ do
1567+ ["{-# LANGUAGE Trustworthy #-}"
1569+ ,"import System.IO.Unsafe"
1570+ ,"import System.IO"
1571+ ,"trustWorthyId :: a -> a"
1572+ ,"trustWorthyId i = unsafePerformIO $ do"
1573+ ," putStrLn \"I'm safe\""
1577+ ["{-# LANGUAGE Safe #-}"
1580+ ,"safeId :: a -> a"
1581+ ,"safeId = trustWorthyId"
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
1586+ expectNoMoreDiagnostics 1 ]
1378thTests :: TestTree
1588thTests :: TestTree
1379thTests =
1589thTests =
1380 testGroup
1590 testGroup
@@ -1400,8 +1610,8 @@ thTests =
1400 "b :: Integer",
1610 "b :: Integer",
1401 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1403− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1404− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1405 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1406 , testSessionWait "newtype-closure" $ do
1616 , testSessionWait "newtype-closure" $ do
1407 let sourceA =
1617 let sourceA =
@@ -1421,8 +1631,8 @@ thTests =
1421 ,"import A"
1631 ,"import A"
1422 ,"b :: Int"
1632 ,"b :: Int"
1423 ,"b = $( a )" ]
1633 ,"b = $( a )" ]
1424− _ <- openDoc' "A.hs" "haskell" sourceA
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1425− _ <- openDoc' "B.hs" "haskell" sourceB
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1426 return ()
1636 return ()
@@ -1431,7 +1641,7 @@ completionTests
1431 = testGroup "completion"
1641 = testGroup "completion"
1432 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1433 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1434− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1435 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1436 liftIO $ map dropDocs compls @?=
1646 liftIO $ map dropDocs compls @?=
1437 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1443,7 +1653,7 @@ completionTests
1444 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1445 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1446− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1447 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1448 liftIO $ map dropDocs compls @?=
1658 liftIO $ map dropDocs compls @?=
1449 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1455,7 +1665,7 @@ completionTests
1456 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1457 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1458− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1459 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1460 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1461 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1472,7 +1682,7 @@ completionTests
1472 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1473 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1474 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1475− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1476 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1477 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1478 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
@@ -1486,9 +1696,30 @@ completionTests
1487 , testSessionWait "keyword" $ do
1697 , testSessionWait "keyword" $ do
1488 let source = T.unlines ["module A where", "f = newty"]
1698 let source = T.unlines ["module A where", "f = newty"]
1489− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
1490 compls <- getCompletions docId (Position 1 9)
1700 compls <- getCompletions docId (Position 1 9)
1491 liftIO $ compls @?= [keywordItem "newtype"]
1701 liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
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 "*")]
1494 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1496,6 +1727,7 @@ completionTests
1496 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1497 { _label = label
1728 { _label = label
1498 , _kind = kind
1729 , _kind = kind
1499 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1500 , _documentation = Nothing
1732 , _documentation = Nothing
1501 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1513,6 +1745,7 @@ completionTests
1513 keywordItem label = CompletionItem
1745 keywordItem label = CompletionItem
1514 { _label = label
1746 { _label = label
1515 , _kind = Just CiKeyword
1747 , _kind = Just CiKeyword
1516 , _detail = Nothing
1749 , _detail = Nothing
1517 , _documentation = Nothing
1750 , _documentation = Nothing
1518 , _deprecated = Nothing
1751 , _deprecated = Nothing
@@ -1540,7 +1773,7 @@ outlineTests = testGroup
1540 "outline"
1773 "outline"
1541 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1542 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1543− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1544 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1545 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1546 [ moduleSymbol
1779 [ moduleSymbol
@@ -1553,7 +1786,7 @@ outlineTests = testGroup
1554 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1555 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1556− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1557 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1558 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1559 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1561,7 +1794,7 @@ outlineTests = testGroup
1562 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1563 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1564− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1565 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1566 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1567 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1570,7 +1803,7 @@ outlineTests = testGroup
1570 , "type family A a"
1803 , "type family A a"
1571 , "type instance A () = ()"
1804 , "type instance A () = ()"
1573− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1574 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1575 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1576 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1578,7 +1811,7 @@ outlineTests = testGroup
1579 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1580 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1581− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1582 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1583 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1584 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1587,7 +1820,7 @@ outlineTests = testGroup
1587 , "data family A a"
1820 , "data family A a"
1588 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1590− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1591 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1592 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1593 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1595,36 +1828,36 @@ outlineTests = testGroup
1596 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1597 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1598− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1599 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1600 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1601 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1602 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1603 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1604− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1605 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1606 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1607 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1608 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1609 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1610− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1611 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1612 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1613 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1614 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1615 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1616− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1617 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1618 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1619 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1620 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1621− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1622 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1623 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1624 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1625 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1626 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1627− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1628 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1629 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1630 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1632,18 +1865,47 @@ outlineTests = testGroup
1632 (R 0 0 0 10)
1865 (R 0 0 0 10)
1633 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1868+ , testSessionWait "record fields" $ do
1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870+ docId <- createDoc "A.hs" "haskell" source
1871+ symbols <- getDocumentSymbols docId
1872+ liftIO $ symbols @=? Left
1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875+ [ docSymbol "x" SkField (R 1 2 1 3)
1876+ , docSymbol "y" SkField (R 2 4 2 5)
1635 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1636 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1882+ docId <- createDoc "A.hs" "haskell" source
1883+ symbols <- getDocumentSymbols docId
1884+ liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1891+ , testSessionWait "multiple import" $ do
1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1637− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
1638 symbols <- getDocumentSymbols docId
1894 symbols <- getDocumentSymbols docId
1639 liftIO $ symbols @?= Left
1895 liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1640− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1641 , testSessionWait "foreign import" $ do
1903 , testSessionWait "foreign import" $ do
1642 let source = T.unlines
1904 let source = T.unlines
1643 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1644 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1646− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1647 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1648 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1649 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1651,7 +1913,7 @@ outlineTests = testGroup
1651 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1652 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1654− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1655 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1656 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
@@ -1664,6 +1926,8 @@ outlineTests = testGroup
1664 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1665 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1666 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1928 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1929+ docSymbolWithChildren' name kind loc selectionLoc cc =
1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
1667 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
@@ -1685,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1685xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1686xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1688data Expect
1959data Expect
1689 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1690-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1691 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1692 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1699,6 +1971,9 @@ data Expect
1699mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1700mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1702haddockTests :: TestTree
1977haddockTests :: TestTree
1703haddockTests
1978haddockTests
1704 = testGroup "haddock"
1979 = testGroup "haddock"
@@ -1754,6 +2029,167 @@ haddockTests
1755 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2030 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2032+cradleTests :: TestTree
2033+cradleTests = testGroup "cradle"
2034+ [testGroup "dependencies" [sessionDepsArePickedUp]
2035+ ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2039+loadCradleOnlyonce :: TestTree
2040+loadCradleOnlyonce = testGroup "load cradle only once"
2041+ [ testSession' "implicit" implicit
2042+ , testSession' "direct" direct
2046+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047+ "cradle: {direct: {arguments: []}}"
2049+ implicit dir = test dir
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053+ liftIO $ length msgs @?= 1
2054+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056+ liftIO $ length msgs @?= 0
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059+ liftIO $ length msgs @?= 0
2062+dependentFileTest :: TestTree
2063+dependentFileTest = testGroup "addDependentFile"
2064+ [testGroup "file-changed" [testSession' "test" test]
2068+ -- If the file contains B then no type error
2069+ -- otherwise type error
2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071+ let fooContent = T.unlines
2072+ [ "{-# LANGUAGE TemplateHaskell #-}"
2073+ , "module Foo where"
2074+ , "import Language.Haskell.TH.Syntax"
2077+ , " qAddDependentFile \"dep-file.txt\""
2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"
2079+ , " if f == \"B\" then [| 1 |] else lift f)"
2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]
2082+ _ <-createDoc "Foo.hs" "haskell" fooContent
2083+ doc <- createDoc "Baz.hs" "haskell" bazContent
2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086+ -- Now modify the dependent file
2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088+ let change = TextDocumentContentChangeEvent
2089+ { _range = Just (Range (Position 2 0) (Position 2 6))
2090+ , _rangeLength = Nothing
2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well
2094+ changeDoc doc [change]
2095+ expectDiagnostics [("Foo.hs", [])]
2098+cradleLoadedMessage :: Session FromServerMessage
2099+cradleLoadedMessage = satisfy $ \case
2100+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2103+cradleLoadedMethod :: T.Text
2104+cradleLoadedMethod = "ghcide/cradle/loaded"
2106+-- Stack sets this which trips up cabal in the multi-component tests.
2107+-- However, our plugin tests rely on those env vars so we unset it locally.
2108+withoutStackEnv :: IO a -> IO a
2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2115+ [ "GHC_PACKAGE_PATH"
2116+ , "GHC_ENVIRONMENT"
2117+ , "HASKELL_DIST_DIR"
2118+ , "HASKELL_PACKAGE_SANDBOX"
2119+ , "HASKELL_PACKAGE_SANDBOXES"
2121+ restore var Nothing = unsetEnv var
2122+ restore var (Just val) = setEnv var val True
2124+simpleMultiTest :: TestTree
2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126+ let aPath = dir </> "a/A.hs"
2127+ bPath = dir </> "b/B.hs"
2128+ aSource <- liftIO $ readFileUtf8 aPath
2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130+ expectNoMoreDiagnostics 0.5
2131+ bSource <- liftIO $ readFileUtf8 bPath
2132+ bdoc <- createDoc bPath "haskell" bSource
2133+ expectNoMoreDiagnostics 0.5
2134+ locs <- getDefinitions bdoc (Position 2 7)
2135+ let fooL = mkL adoc 2 0 2 3
2136+ checkDefs locs (pure [fooL])
2137+ expectNoMoreDiagnostics 0.5
2139+-- Like simpleMultiTest but open the files in the other order
2140+simpleMultiTest2 :: TestTree
2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142+ let aPath = dir </> "a/A.hs"
2143+ bPath = dir </> "b/B.hs"
2144+ bSource <- liftIO $ readFileUtf8 bPath
2145+ bdoc <- createDoc bPath "haskell" bSource
2146+ expectNoMoreDiagnostics 5
2147+ aSource <- liftIO $ readFileUtf8 aPath
2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149+ -- Need to have some delay here or the test fails
2150+ expectNoMoreDiagnostics 5
2151+ locs <- getDefinitions bdoc (Position 2 7)
2152+ let fooL = mkL adoc 2 0 2 3
2153+ checkDefs locs (pure [fooL])
2154+ expectNoMoreDiagnostics 0.5
2156+sessionDepsArePickedUp :: TestTree
2157+sessionDepsArePickedUp = testSession'
2158+ "session-deps-are-picked-up"
2162+ (dir </> "hie.yaml")
2163+ "cradle: {direct: {arguments: []}}"
2164+ -- Open without OverloadedStrings and expect an error.
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
2167+ [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168+ -- Update hie.yaml to enable OverloadedStrings.
2171+ (dir </> "hie.yaml")
2172+ "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173+ -- Send change event.
2175+ TextDocumentContentChangeEvent
2176+ { _range = Just (Range (Position 4 0) (Position 4 0)),
2177+ _rangeLength = Nothing,
2180+ changeDoc doc [change]
2182+ expectDiagnostics [("Foo.hs", [])]
2186+ [ "module Foo where",
2187+ "import Data.Text",
1757----------------------------------------------------------------------
2193----------------------------------------------------------------------
@@ -1761,6 +2197,12 @@ haddockTests
1761testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1762testSession name = testCase name . run
2198testSession name = testCase name . run
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2203+testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204+testSession' name = testCase name . run'
1764testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
1765testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
1766 -- Check that any diagnostics produced were already consumed by the test case.
2208 -- Check that any diagnostics produced were already consumed by the test case.
@@ -1771,24 +2213,53 @@ testSessionWait name = testSession name .
1771 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
1772 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
1774−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
1775−pickActionWithTitle title actions = head
2217+pickActionWithTitle title actions = do
2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219+ return $ head matches
2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions
1776− [ action
2226+ [ action
1777− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
1778− , title == actionTitle ]
2228+ , title == actionTitle
1780mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
1781mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
1783run :: Session a -> IO a
2234run :: Session a -> IO a
1784−run s = withTempDir $ \dir -> do
2235+run s = withTempDir $ \dir -> runInDir dir s
2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239+ copyTestDataFiles dir prefix
2240+ runInDir dir (s dir)
2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243+copyTestDataFiles dir prefix = do
2244+ -- Copy all the test data files to the temporary workspace
2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246+ for_ testDataFiles $ \f -> do
2247+ createDirectoryIfMissing True $ dir </> takeDirectory f
2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)
2250+run' :: (FilePath -> Session a) -> IO a
2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)
2253+runInDir :: FilePath -> Session a -> IO a
1785 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
1787 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
1788 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
1789 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
1791− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
1792 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
1793 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
1794 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
@@ -1805,7 +2276,7 @@ run s = withTempDir $ \dir -> do
1805openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
1806openTestDataDoc path = do
2277openTestDataDoc path = do
1807 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
1808− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
1810findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
1811findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -1820,7 +2291,7 @@ findCodeActions doc range expectedTitles = do
1820 [ actionTitle
2291 [ actionTitle
1821 | CACodeAction CodeAction { _title = actionTitle } <- actions
2292 | CACodeAction CodeAction { _title = actionTitle } <- actions
1823− ++ "is not a superset of "
2294+ ++ " is not a superset of "
1824 ++ show expectedTitles
2295 ++ show expectedTitles
1825 liftIO $ case matches of
2296 liftIO $ case matches of
1826 Nothing -> assertFailure msg
2297 Nothing -> assertFailure msg
@@ -1833,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
1833unitTests :: TestTree
2304unitTests :: TestTree
1834unitTests = do
2305unitTests = do
1835 testGroup "Unit"
2306 testGroup "Unit"
1836− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
1837− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""
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:"
2315+ , testCase "from empty path URI" $ do
2316+ let uri = Uri "file://"
2317+ uriToFilePath' uri @?= Just ""
1840−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
1841−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
1842−openDoc' fp name contents = do
1843− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
1844− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
1845− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
1848−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
1849−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
1850−-- At the moment this is just LSPTest.openDoc' but it may change in the future
1851−-- when/if lsp-test implements WatchedFiles
1852−openDoc'' = LSPTest.openDoc'
1854positionMappingTests :: TestTree
2320positionMappingTests :: TestTree
1855positionMappingTests =
2321positionMappingTests =
1856 testGroup "position mapping"
2322 testGroup "position mapping"
@@ -2019,3 +2485,12 @@ nthLine i r
2019 | i == 0 && Rope.rows r == 0 = r
2485 | i == 0 && Rope.rows r == 0 = r
2020 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2021 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490+getWatchedFilesSubscriptionsUntil = do
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs