@@ -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
@@ -855,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
857 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
858− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
859− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
860 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
861 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
862 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -866,6 +951,61 @@ extendImportTests = testGroup "extend import actions"
866 contentAfterAction <- documentContents docB
951 contentAfterAction <- documentContents docB
867 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 ] @?= []
869addExtensionTests :: TestTree
1009addExtensionTests :: TestTree
870addExtensionTests = testGroup "add language extension actions"
1010addExtensionTests = testGroup "add language extension actions"
871 [ testSession "add NamedFieldPuns language extension" $ template
1011 [ testSession "add NamedFieldPuns language extension" $ template
@@ -911,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
913 template initialContent range expectedAction expectedContents = do
1053 template initialContent range expectedAction expectedContents = do
914− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
915 _ <- waitForDiagnostics
1055 _ <- waitForDiagnostics
916 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 CACodeAction action@CodeAction { _title = actionTitle } : _
917 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -934,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
935 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
937− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
938 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
939 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
940 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -958,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
959 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
961− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
962 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
963 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
964 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -997,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
999 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
1000− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1001− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
1002 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
1003 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
1004 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1017,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
1017 [ "module Testing where"
1157 [ "module Testing where"
1018 , "import Data.Mape"
1158 , "import Data.Mape"
1020− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
1021 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
1022 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1023 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 ]
@@ -1054,10 +1194,10 @@ fillTypedHoleTests = let
1054 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
1055 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
1056 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
1057− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
1058 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
1059 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1060− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1061 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
1062 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
1063 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -1094,36 +1234,37 @@ fillTypedHoleTests = let
1095addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
1096addSigActionTests = let
1236addSigActionTests = let
1097− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
1098− moduleH = "module Sigs where"
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1099 before def = T.unlines [header, moduleH, def]
1239 before def = T.unlines [header, moduleH, def]
1100 after' def sig = T.unlines [header, moduleH, sig, def]
1240 after' def sig = T.unlines [header, moduleH, sig, def]
1102 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
1103 let originalCode = before def
1243 let originalCode = before def
1104 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
1105− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1106 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
1107 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1108− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1109 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
1110 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
1111 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
1113 testGroup "add signature"
1253 testGroup "add signature"
1114− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
1115− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1116− , "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"
1117− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1118− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1119− , "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"
1122addSigLensesTests :: TestTree
1263addSigLensesTests :: TestTree
1123addSigLensesTests = let
1264addSigLensesTests = let
1124− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1125 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1126− moduleH = "module Sigs where"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1127 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1128 before withMissing def
1269 before withMissing def
1129 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
@@ -1133,49 +1274,41 @@ addSigLensesTests = let
1133 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1134 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1135 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1136− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1137 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1138 executeCommand c
1279 executeCommand c
1139 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
1140 liftIO $ expectedCode @=? modifiedCode
1281 liftIO $ expectedCode @=? modifiedCode
1142 testGroup "add signature"
1283 testGroup "add signature"
1143− [ testGroup "with warnings enabled"
1284+ [ testGroup title
1144− [ sigSession True "abc = True" "abc :: Bool"
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1145− , 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"
1146− , 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"
1147− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1148− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1149− , 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"
1150− ]
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1151− , testGroup "with warnings disabled"
1152− [ sigSession False "abc = True" "abc :: Bool"
1153− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"
1154− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1155− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1156− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1157− , 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)
1161−findDefinitionAndHoverTests :: TestTree
1162−findDefinitionAndHoverTests = let
1164− tst (get, check) pos targetRange title = testSession title $ do
1165− doc <- openTestDataDoc sourceFilePath
1166− found <- get doc pos
1167− check found targetRange
1169− checkDefs :: [Location] -> [Expect] -> Session ()
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1170− checkDefs defs expectations = traverse_ check expectations where
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1172− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1173− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1174− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1175− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1176− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1177− 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"
1178− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1180 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1181 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1183,8 +1316,19 @@ findDefinitionAndHoverTests = let
1183 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1184 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
1186− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1187− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1189 check expected =
1333 check expected =
1190 case hover of
1334 case hover of
@@ -1227,9 +1371,12 @@ findDefinitionAndHoverTests = let
1228 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1229 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1230− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1232− test runDef runHover look expect title =
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1379+ testM runDef runHover look expect title =
1233 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1234 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1235 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1237,87 +1384,100 @@ findDefinitionAndHoverTests = let
1237 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1239 -- search locations expectations on results
1386 -- search locations expectations on results
1240− 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]
1241− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1242− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1243− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1244− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1245− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1246− 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’"]]
1247− 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"]]
1248− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1249− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1250− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1251− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1252− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1253− 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"]]
1254− 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"]]
1255− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1256− 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’"]]
1257− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1258− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1259− 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]
1260− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1261− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1262− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1263− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1264− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1265 ; constr = [ExpectHoverText ["Monad m"]]
1412 ; constr = [ExpectHoverText ["Monad m"]]
1266− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1267− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1268− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1269− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1270− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1271− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1272− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1273− 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]
1274− 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]
1276 mkFindTests
1425 mkFindTests
1277− -- def hover look expect
1426+ -- def hover look expect
1278− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1279− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1280− , 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
1281− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1282− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1283− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1284− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1285− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1286− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1287− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1288− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1289− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1290− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1291− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1292− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1293− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1294− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1295− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1296− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1297− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1298− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1299− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1300− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1301− , test yes yes spaceL37 space "top-level fn on space #315"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1302− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1303− , test no yes eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1304− , test no yes intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1305− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1306− , test no yes intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1307− , test no yes chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1308− , test no yes txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1309− , test no yes lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1310− , test no yes docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1311− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1312− , 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)"
1314 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1315 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1316 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1317 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
1319pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1320−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1321 let content =
1481 let content =
1322 T.unlines
1482 T.unlines
1323 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1331,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1331 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1332 , "foo a b = a + c"
1492 , "foo a b = a + c"
1334− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1335 expectDiagnostics
1495 expectDiagnostics
1336 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1337 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1358,7 +1518,7 @@ cppTests =
1358 run $ expectError content (2, 1)
1518 run $ expectError content (2, 1)
1360 , testSessionWait "cpp-ghcide" $ do
1520 , testSessionWait "cpp-ghcide" $ do
1361− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1362 ["{-# LANGUAGE CPP #-}"
1522 ["{-# LANGUAGE CPP #-}"
1363 ,"main ="
1523 ,"main ="
1364 ,"#ifdef __GHCIDE__"
1524 ,"#ifdef __GHCIDE__"
@@ -1372,7 +1532,7 @@ cppTests =
1373 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1374 expectError content cursor = do
1534 expectError content cursor = do
1375− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1376 expectDiagnostics
1536 expectDiagnostics
1377 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1378 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1388,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1388 , "module Testing where"
1548 , "module Testing where"
1389 , "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
1391− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1392 expectDiagnostics
1552 expectDiagnostics
1393 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1394 [(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 ]
1398thTests :: TestTree
1588thTests :: TestTree
1399thTests =
1589thTests =
1400 testGroup
1590 testGroup
@@ -1420,8 +1610,8 @@ thTests =
1420 "b :: Integer",
1610 "b :: Integer",
1421 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1423− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1424− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1425 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1426 , testSessionWait "newtype-closure" $ do
1616 , testSessionWait "newtype-closure" $ do
1427 let sourceA =
1617 let sourceA =
@@ -1441,8 +1631,8 @@ thTests =
1441 ,"import A"
1631 ,"import A"
1442 ,"b :: Int"
1632 ,"b :: Int"
1443 ,"b = $( a )" ]
1633 ,"b = $( a )" ]
1444− _ <- openDoc' "A.hs" "haskell" sourceA
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1445− _ <- openDoc' "B.hs" "haskell" sourceB
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1446 return ()
1636 return ()
@@ -1451,7 +1641,7 @@ completionTests
1451 = testGroup "completion"
1641 = testGroup "completion"
1452 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1453 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1454− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1455 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1456 liftIO $ map dropDocs compls @?=
1646 liftIO $ map dropDocs compls @?=
1457 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1463,7 +1653,7 @@ completionTests
1464 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1465 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1466− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1467 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1468 liftIO $ map dropDocs compls @?=
1658 liftIO $ map dropDocs compls @?=
1469 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1475,7 +1665,7 @@ completionTests
1476 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1477 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 = ()"]
1478− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1479 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1480 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"]]
1481 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1492,7 +1682,7 @@ completionTests
1492 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1493 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1494 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 = ()"]
1495− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1496 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1497 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"]]
1498 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
@@ -1506,9 +1696,30 @@ completionTests
1507 , testSessionWait "keyword" $ do
1697 , testSessionWait "keyword" $ do
1508 let source = T.unlines ["module A where", "f = newty"]
1698 let source = T.unlines ["module A where", "f = newty"]
1509− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
1510 compls <- getCompletions docId (Position 1 9)
1700 compls <- getCompletions docId (Position 1 9)
1511 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 "*")]
1514 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1516,6 +1727,7 @@ completionTests
1516 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1517 { _label = label
1728 { _label = label
1518 , _kind = kind
1729 , _kind = kind
1519 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1520 , _documentation = Nothing
1732 , _documentation = Nothing
1521 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1533,6 +1745,7 @@ completionTests
1533 keywordItem label = CompletionItem
1745 keywordItem label = CompletionItem
1534 { _label = label
1746 { _label = label
1535 , _kind = Just CiKeyword
1747 , _kind = Just CiKeyword
1536 , _detail = Nothing
1749 , _detail = Nothing
1537 , _documentation = Nothing
1750 , _documentation = Nothing
1538 , _deprecated = Nothing
1751 , _deprecated = Nothing
@@ -1560,7 +1773,7 @@ outlineTests = testGroup
1560 "outline"
1773 "outline"
1561 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1562 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"]
1563− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1564 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1565 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1566 [ moduleSymbol
1779 [ moduleSymbol
@@ -1573,7 +1786,7 @@ outlineTests = testGroup
1574 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1575 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1576− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1577 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1578 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1579 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1581,7 +1794,7 @@ outlineTests = testGroup
1582 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1583 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1584− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1585 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1586 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)]
1587 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1590,7 +1803,7 @@ outlineTests = testGroup
1590 , "type family A a"
1803 , "type family A a"
1591 , "type instance A () = ()"
1804 , "type instance A () = ()"
1593− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1594 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1595 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1596 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1598,7 +1811,7 @@ outlineTests = testGroup
1599 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1600 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1601− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1602 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1603 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)]
1604 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1607,7 +1820,7 @@ outlineTests = testGroup
1607 , "data family A a"
1820 , "data family A a"
1608 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1610− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1611 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1612 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1613 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1615,36 +1828,36 @@ outlineTests = testGroup
1616 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1617 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1618− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1619 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1620 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1621 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1622 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1623 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1624− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1625 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1626 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1627 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1628 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1629 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1630− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1631 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1632 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1633 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1634 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1635 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1636− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1637 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1638 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1639 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1640 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1641− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1642 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1643 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1644 [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)]
1645 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1646 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1647− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1648 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1649 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1650 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1652,18 +1865,47 @@ outlineTests = testGroup
1652 (R 0 0 0 10)
1865 (R 0 0 0 10)
1653 [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)
1655 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1656 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1657− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
1658 symbols <- getDocumentSymbols docId
1883 symbols <- getDocumentSymbols docId
1659 liftIO $ symbols @?= Left
1884 liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1660− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]
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", ""]
1893+ docId <- createDoc "A.hs" "haskell" source
1894+ symbols <- getDocumentSymbols docId
1895+ liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1661 , testSessionWait "foreign import" $ do
1903 , testSessionWait "foreign import" $ do
1662 let source = T.unlines
1904 let source = T.unlines
1663 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1664 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1666− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1667 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1668 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)]
1669 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1671,7 +1913,7 @@ outlineTests = testGroup
1671 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1672 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1674− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1675 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1676 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)]
@@ -1684,6 +1926,8 @@ outlineTests = testGroup
1684 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1685 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1686 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)
1687 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
@@ -1705,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1705xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1706xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1708data Expect
1959data Expect
1709 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1710-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1711 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1712 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1719,6 +1971,9 @@ data Expect
1719mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1720mkR 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
1722haddockTests :: TestTree
1977haddockTests :: TestTree
1723haddockTests
1978haddockTests
1724 = testGroup "haddock"
1979 = testGroup "haddock"
@@ -1774,6 +2029,167 @@ haddockTests
1775 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",
1777----------------------------------------------------------------------
2193----------------------------------------------------------------------
@@ -1781,6 +2197,12 @@ haddockTests
1781testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1782testSession 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'
1784testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
1785testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
1786 -- 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.
@@ -1791,24 +2213,53 @@ testSessionWait name = testSession name .
1791 -- 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.
1792 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
1794−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
1795−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
1796− [ action
2226+ [ action
1797− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
1798− , title == actionTitle ]
2228+ , title == actionTitle
1800mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
1801mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
1803run :: Session a -> IO a
2234run :: Session a -> IO a
1804−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
1805 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
1807 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
1808 -- 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
1809 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
1811− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
1812 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
1813 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
1814 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
@@ -1825,7 +2276,7 @@ run s = withTempDir $ \dir -> do
1825openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
1826openTestDataDoc path = do
2277openTestDataDoc path = do
1827 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
1828− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
1830findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
1831findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -1840,7 +2291,7 @@ findCodeActions doc range expectedTitles = do
1840 [ actionTitle
2291 [ actionTitle
1841 | CACodeAction CodeAction { _title = actionTitle } <- actions
2292 | CACodeAction CodeAction { _title = actionTitle } <- actions
1843− ++ "is not a superset of "
2294+ ++ " is not a superset of "
1844 ++ show expectedTitles
2295 ++ show expectedTitles
1845 liftIO $ case matches of
2296 liftIO $ case matches of
1846 Nothing -> assertFailure msg
2297 Nothing -> assertFailure msg
@@ -1853,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
1853unitTests :: TestTree
2304unitTests :: TestTree
1854unitTests = do
2305unitTests = do
1855 testGroup "Unit"
2306 testGroup "Unit"
1856− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
1857− 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 ""
1860−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
1861−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
1862−openDoc' fp name contents = do
1863− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
1864− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
1865− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
1868−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
1869−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
1870−-- At the moment this is just LSPTest.openDoc' but it may change in the future
1871−-- when/if lsp-test implements WatchedFiles
1872−openDoc'' = LSPTest.openDoc'
1874positionMappingTests :: TestTree
2320positionMappingTests :: TestTree
1875positionMappingTests =
2321positionMappingTests =
1876 testGroup "position mapping"
2322 testGroup "position mapping"
@@ -2039,3 +2485,12 @@ nthLine i r
2039 | i == 0 && Rope.rows r == 0 = r
2485 | i == 0 && Rope.rows r == 0 = r
2040 | 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)
2041 | 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