@@ -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,50 +10,74 @@
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
20+import Data.Rope.UTF16 (Rope)
21+import qualified Data.Rope.UTF16 as Rope
22+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
18import Development.IDE.GHC.Util
23import Development.IDE.GHC.Util
19import qualified Data.Text as T
24import qualified Data.Text as T
26+import Development.IDE.Spans.Common
20import Development.IDE.Test
27import Development.IDE.Test
21import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
22import Development.IDE.Types.Location
29import Development.IDE.Types.Location
30+import Development.Shake (getDirectoryFilesIO)
23import Language.Haskell.LSP.Test
31import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
24import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
25import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
36+import Language.Haskell.LSP.VFS (applyChange)
26−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
27import System.FilePath
39import System.FilePath
28import System.IO.Extra
40import System.IO.Extra
29import System.Directory
41import System.Directory
42+import Test.QuickCheck
43+import Test.QuickCheck.Instances ()
30import Test.Tasty
44import Test.Tasty
31−import Test.Tasty.HUnit
32import Test.Tasty.ExpectedFailure
45import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
47+import Test.Tasty.HUnit
48+import Test.Tasty.QuickCheck
33import Data.Maybe
49import Data.Maybe
35main :: IO ()
51main :: IO ()
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
36−main = defaultMain $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
37− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
38− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
39− void (message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
40− void (message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
41− closeDoc doc
60+ closeDoc doc
42− void (message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
43− , initializeResponseTests
62+ , initializeResponseTests
44− , completionTests
63+ , completionTests
45− , cppTests
64+ , cppTests
46− , diagnosticTests
65+ , diagnosticTests
47− , codeActionTests
66+ , codeActionTests
48− , codeLensesTests
67+ , codeLensesTests
49− , outlineTests
68+ , outlineTests
50− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
51− , pluginTests
70+ , pluginTests
52− , preprocessorTests
71+ , preprocessorTests
53− , thTests
72+ , thTests
54− , unitTests
74+ , unitTests
76+ , positionMappingTests
57initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
58initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -67,7 +92,7 @@ initializeResponseTests = withResource acquire release tests where
67 testGroup "initialize response capabilities"
92 testGroup "initialize response capabilities"
68 [ chk " text doc sync" _textDocumentSync tds
93 [ chk " text doc sync" _textDocumentSync tds
69 , chk " hover" _hoverProvider (Just True)
94 , chk " hover" _hoverProvider (Just True)
70− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)
95+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
71 , chk "NO signature help" _signatureHelpProvider Nothing
96 , chk "NO signature help" _signatureHelpProvider Nothing
72 , chk " goto definition" _definitionProvider (Just True)
97 , chk " goto definition" _definitionProvider (Just True)
73 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
98 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
@@ -87,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where
87 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
88 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
89 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
90− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
91− , chk "NO workspace" _workspace nothingWorkspace
116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
92 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
@@ -99,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where
99 , _willSaveWaitUntil = Nothing
124 , _willSaveWaitUntil = Nothing
100 , _save = Just (SaveOptions {_includeText = Nothing})}))
125 , _save = Just (SaveOptions {_includeText = Nothing})}))
102− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
104 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
105 chk title getActual expected =
128 chk title getActual expected =
106 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
108 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
109− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
110 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
112 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -120,7 +152,7 @@ diagnosticTests :: TestTree
120diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
121 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
122 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
123− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
124 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
125 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
126 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -131,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"
131 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
132 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
133 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
134− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
135− void (message :: Session WorkDoneProgressCreateRequest)
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
136− void (message :: Session WorkDoneProgressBeginNotification)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
137 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
138 { _range = Just (Range (Position 0 15) (Position 0 18))
170 { _range = Just (Range (Position 0 15) (Position 0 18))
139 , _rangeLength = Nothing
171 , _rangeLength = Nothing
@@ -149,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
149 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
150 , "bar a b = cd + b"
182 , "bar a b = cd + b"
152− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
153 expectDiagnostics
185 expectDiagnostics
154 [ ( "Testing.hs"
186 [ ( "Testing.hs"
155 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -163,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
163 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
164 , "foo a b = a + b"
196 , "foo a b = a + b"
166− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
167 expectDiagnostics
199 expectDiagnostics
168 [ ( "Testing.hs"
200 [ ( "Testing.hs"
169 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -175,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
175 , "foo :: Int -> String"
207 , "foo :: Int -> String"
176 , "foo a = _ a"
208 , "foo a = _ a"
178− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
179 expectDiagnostics
211 expectDiagnostics
180 [ ( "Testing.hs"
212 [ ( "Testing.hs"
181 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -197,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
197 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
198 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
199 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
200− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
201− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
202 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
204 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
205 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
206 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
207− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
210 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
211 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
212− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
213 let contentB = T.unlines
244 let contentB = T.unlines
214 [ "module ModuleB where"
245 [ "module ModuleB where"
215 , "import ModuleA"
246 , "import ModuleA"
217− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
218 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
219 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
220 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -227,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"
227 [ "module ModuleB where"
258 [ "module ModuleB where"
228 , "import ModuleA"
259 , "import ModuleA"
230− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
231 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
232 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
233− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
234 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
266+ , testSessionWait "add missing module (non workspace)" $ do
267+ let contentB = T.unlines
268+ [ "module ModuleB where"
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272+ expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273+ let contentA = T.unlines [ "module ModuleA where" ]
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275+ expectDiagnostics [("/tmp/ModuleB.hs", [])]
235 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
236 let contentA = T.unlines
277 let contentA = T.unlines
237 [ "module ModuleA where"
278 [ "module ModuleA where"
@@ -241,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
241 [ "module ModuleB where"
282 [ "module ModuleB where"
242 , "import ModuleA"
283 , "import ModuleA"
244− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
245− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
246 expectDiagnostics
287 expectDiagnostics
247 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
248 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -263,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
263 let contentBboot = T.unlines
304 let contentBboot = T.unlines
264 [ "module ModuleB where"
305 [ "module ModuleB where"
266− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
267− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
268− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
269 expectDiagnostics []
310 expectDiagnostics []
270 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
271 let contentB = T.unlines
312 let contentB = T.unlines
@@ -287,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
287 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
288 , "y = x"
329 , "y = x"
290− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
291− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
292− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
293− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
294 expectDiagnostics []
335 expectDiagnostics []
295 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
296 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -299,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
299 , "module ModuleB where"
340 , "module ModuleB where"
300 , "import ModuleA"
341 , "import ModuleA"
302− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
303− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
304 expectDiagnostics
345 expectDiagnostics
305 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
306 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -322,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
322 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
323 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
325− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
326− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
327 expectDiagnostics
368 expectDiagnostics
328 [ ( "Main.hs"
369 [ ( "Main.hs"
329 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -338,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
338 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
339 , "foo a = 1"
380 , "foo a = 1"
341− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
342 expectDiagnostics
383 expectDiagnostics
343 [ ( "Foo.hs"
384 [ ( "Foo.hs"
344 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -363,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
363 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
364 uriB <- pure $
405 uriB <- pure $
365 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
366− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
367 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
368 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
369 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
370 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
371 uriA <- pure $
412 uriA <- pure $
372 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
373− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
374 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
375 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
376 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
377− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
378 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
379 -- 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
380 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -383,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
383 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
384 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
385 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
388codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -391,10 +464,13 @@ codeActionTests = testGroup "code actions"
391 , typeWildCardActionTests
464 , typeWildCardActionTests
392 , removeImportTests
465 , removeImportTests
393 , extendImportTests
466 , extendImportTests
467+ , suggestImportTests
394 , fixConstructorImportTests
469 , fixConstructorImportTests
395 , importRenameActionTests
470 , importRenameActionTests
396 , fillTypedHoleTests
471 , fillTypedHoleTests
397 , addSigActionTests
472 , addSigActionTests
473+ , insertNewDefinitionTests
400codeLensesTests :: TestTree
476codeLensesTests :: TestTree
@@ -402,6 +478,33 @@ codeLensesTests = testGroup "code lenses"
402 [ addSigLensesTests
478 [ addSigLensesTests
481+watchedFilesTests :: TestTree
482+watchedFilesTests = testGroup "watched files"
483+ [ testSession' "workspace files" $ \sessionDir -> do
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
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
495+ , testSession' "non workspace file" $ \sessionDir -> do
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503+ liftIO $ length watchedFileRegs @?= 2
505+ -- TODO add a test for didChangeWorkspaceFolder
405renameActionTests :: TestTree
508renameActionTests :: TestTree
406renameActionTests = testGroup "rename actions"
509renameActionTests = testGroup "rename actions"
407 [ testSession "change to local variable name" $ do
510 [ testSession "change to local variable name" $ do
@@ -410,11 +513,9 @@ renameActionTests = testGroup "rename actions"
410 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
411 , "foo argName = argNme"
514 , "foo argName = argNme"
413− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
414 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
415− [CACodeAction action@CodeAction { _title = actionTitle }]
416− <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
518+ action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
417− liftIO $ "Replace with ‘argName’" @=? actionTitle
418 executeCodeAction action
519 executeCodeAction action
419 contentAfterAction <- documentContents doc
520 contentAfterAction <- documentContents doc
420 let expectedContentAfterAction = T.unlines
521 let expectedContentAfterAction = T.unlines
@@ -430,11 +531,9 @@ renameActionTests = testGroup "rename actions"
430 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
431 , "foo = maybToList"
532 , "foo = maybToList"
433− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
434 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
435− [CACodeAction action@CodeAction { _title = actionTitle }]
436− <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
536+ action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
437− liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
438 executeCodeAction action
537 executeCodeAction action
439 contentAfterAction <- documentContents doc
538 contentAfterAction <- documentContents doc
440 let expectedContentAfterAction = T.unlines
539 let expectedContentAfterAction = T.unlines
@@ -450,12 +549,11 @@ renameActionTests = testGroup "rename actions"
450 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
451 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
453− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
454 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
455− actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
554+ _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
456− let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
457− expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555+ ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
458− liftIO $ expectedActionTitles @=? actionTitles
556+ return()
459 , testSession "change infix function" $ do
557 , testSession "change infix function" $ do
460 let content = T.unlines
558 let content = T.unlines
461 [ "module Testing where"
559 [ "module Testing where"
@@ -463,7 +561,7 @@ renameActionTests = testGroup "rename actions"
463 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
464 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
466− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
467 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
468 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
469 [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 ]
@@ -486,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
486 , "func :: _"
584 , "func :: _"
487 , "func x = x"
585 , "func x = x"
489− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
490 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
491 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
492 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -506,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
506 , "func :: _"
604 , "func :: _"
507 , "func x y = x + y"
605 , "func x y = x + y"
509− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
510 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
511 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
512 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -529,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
529 , " y = x * 2"
627 , " y = x * 2"
530 , " in y"
628 , " in y"
532− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
533 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
534 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
535 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -554,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
554 let contentA = T.unlines
652 let contentA = T.unlines
555 [ "module ModuleA where"
653 [ "module ModuleA where"
557− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
558 let contentB = T.unlines
656 let contentB = T.unlines
559 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
560 , "module ModuleB where"
658 , "module ModuleB where"
@@ -562,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
562 , "stuffB :: Integer"
660 , "stuffB :: Integer"
563 , "stuffB = 123"
661 , "stuffB = 123"
565− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
566 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
567 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
568 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -580,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
580 let contentA = T.unlines
678 let contentA = T.unlines
581 [ "module ModuleA where"
679 [ "module ModuleA where"
583− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
584 let contentB = T.unlines
682 let contentB = T.unlines
585 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
586 , "module ModuleB where"
684 , "module ModuleB where"
@@ -588,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
588 , "stuffB :: Integer"
686 , "stuffB :: Integer"
589 , "stuffB = 123"
687 , "stuffB = 123"
591− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
592 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
593 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
594 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -610,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
610 , "stuffB = 123"
708 , "stuffB = 123"
611 , "stuffC = ()"
709 , "stuffC = ()"
613− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
614 let contentB = T.unlines
712 let contentB = T.unlines
615 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
616 , "module ModuleB where"
714 , "module ModuleB where"
617 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
618 , "main = print stuffB"
716 , "main = print stuffB"
620− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
621 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
622 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
623 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -631,29 +729,26 @@ removeImportTests = testGroup "remove import actions"
631 , "main = print stuffB"
729 , "main = print stuffB"
633 liftIO $ expectedContentAfterAction @=? contentAfterAction
731 liftIO $ expectedContentAfterAction @=? contentAfterAction
634− , testSession "redundant symbol binding" $ do
732+ , testSession "redundant operator" $ do
635 let contentA = T.unlines
733 let contentA = T.unlines
636 [ "module ModuleA where"
734 [ "module ModuleA where"
637 , "a !! b = a"
735 , "a !! b = a"
638 , "stuffB :: Integer"
737 , "stuffB :: Integer"
639 , "stuffB = 123"
738 , "stuffB = 123"
641− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
642 let contentB = T.unlines
741 let contentB = T.unlines
643 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
644 , "module ModuleB where"
743 , "module ModuleB where"
645− , "import qualified ModuleA as A ((!!), stuffB, (!!))"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
646 , "main = print A.stuffB"
745 , "main = print A.stuffB"
648− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
649 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
650 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
651 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
652−#if MIN_GHC_API_VERSION(8,6,0)
653− liftIO $ "Remove !! from import" @=? actionTitle
655− liftIO $ "Remove A.!! from import" @=? actionTitle
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
657 executeCodeAction action
752 executeCodeAction action
658 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
659 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -663,21 +758,21 @@ removeImportTests = testGroup "remove import actions"
663 , "main = print A.stuffB"
758 , "main = print A.stuffB"
665 liftIO $ expectedContentAfterAction @=? contentAfterAction
760 liftIO $ expectedContentAfterAction @=? contentAfterAction
666− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do
761+ , testSession "redundant all import" $ do
667 let contentA = T.unlines
762 let contentA = T.unlines
668 [ "module ModuleA where"
763 [ "module ModuleA where"
669 , "data A = A"
764 , "data A = A"
670 , "stuffB :: Integer"
765 , "stuffB :: Integer"
671 , "stuffB = 123"
766 , "stuffB = 123"
673− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
674 let contentB = T.unlines
769 let contentB = T.unlines
675 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
676 , "module ModuleB where"
771 , "module ModuleB where"
677 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
678 , "main = print stuffB"
773 , "main = print stuffB"
680− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
681 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
682 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
683 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -691,6 +786,33 @@ removeImportTests = testGroup "remove import actions"
691 , "main = print stuffB"
786 , "main = print stuffB"
693 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
696extendImportTests :: TestTree
818extendImportTests :: TestTree
@@ -715,6 +837,26 @@ extendImportTests = testGroup "extend import actions"
715 , "import ModuleA as A (stuffA, stuffB)"
837 , "import ModuleA as A (stuffA, stuffB)"
716 , "main = print (stuffA, stuffB)"
838 , "main = print (stuffA, stuffB)"
840+ , testSession "extend single line import with operator" $ template
842+ [ "module ModuleA where"
843+ , "(.*) :: Integer -> Integer -> Integer"
845+ , "stuffB :: Integer"
849+ [ "module ModuleB where"
850+ , "import ModuleA as A (stuffB)"
851+ , "main = print (stuffB .* stuffB)"
853+ (Range (Position 3 17) (Position 3 18))
854+ "Add .* to the import list of ModuleA"
856+ [ "module ModuleB where"
857+ , "import ModuleA as A ((.*), stuffB)"
858+ , "main = print (stuffB .* stuffB)"
718 , testSession "extend single line import with type" $ template
860 , testSession "extend single line import with type" $ template
719 (T.unlines
861 (T.unlines
720 [ "module ModuleA where"
862 [ "module ModuleA where"
@@ -798,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
800 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
801− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
802− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
803 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
804 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
805 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -809,6 +951,172 @@ extendImportTests = testGroup "extend import actions"
809 contentAfterAction <- documentContents docB
951 contentAfterAction <- documentContents docB
810 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 ] @?= []
1009+addExtensionTests :: TestTree
1010+addExtensionTests = testGroup "add language extension actions"
1011+ [ testSession "add NamedFieldPuns language extension" $ template
1013+ [ "module Module where"
1015+ , "data A = A { getA :: Bool }"
1018+ , "f A { getA } = getA"
1020+ (Range (Position 0 0) (Position 0 0))
1021+ "Add NamedFieldPuns extension"
1023+ [ "{-# LANGUAGE NamedFieldPuns #-}"
1024+ , "module Module where"
1026+ , "data A = A { getA :: Bool }"
1029+ , "f A { getA } = getA"
1031+ , testSession "add RecordWildCards language extension" $ template
1033+ [ "module Module where"
1035+ , "data A = A { getA :: Bool }"
1038+ , "f A { .. } = getA"
1040+ (Range (Position 0 0) (Position 0 0))
1041+ "Add RecordWildCards extension"
1043+ [ "{-# LANGUAGE RecordWildCards #-}"
1044+ , "module Module where"
1046+ , "data A = A { getA :: Bool }"
1049+ , "f A { .. } = getA"
1053+ template initialContent range expectedAction expectedContents = do
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1055+ _ <- waitForDiagnostics
1056+ CACodeAction action@CodeAction { _title = actionTitle } : _
1057+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058+ getCodeActions doc range
1059+ liftIO $ expectedAction @=? actionTitle
1060+ executeCodeAction action
1061+ contentAfterAction <- documentContents doc
1062+ liftIO $ expectedContents @=? contentAfterAction
1065+insertNewDefinitionTests :: TestTree
1066+insertNewDefinitionTests = testGroup "insert new definition actions"
1067+ [ testSession "insert new function definition" $ do
1069+ ["foo True = select [True]"
1071+ ,"foo False = False"
1075+ ,"someOtherCode = ()"
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1078+ _ <- waitForDiagnostics
1079+ CACodeAction action@CodeAction { _title = actionTitle } : _
1080+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1081+ getCodeActions docB (R 1 0 1 50)
1082+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1083+ executeCodeAction action
1084+ contentAfterAction <- documentContents docB
1085+ liftIO $ contentAfterAction @?= T.unlines (txtB ++
1087+ , "select :: [Bool] -> Bool"
1088+ , "select = error \"not implemented\""
1091+ , testSession "define a hole" $ do
1093+ ["foo True = _select [True]"
1095+ ,"foo False = False"
1099+ ,"someOtherCode = ()"
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1102+ _ <- waitForDiagnostics
1103+ CACodeAction action@CodeAction { _title = actionTitle } : _
1104+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1105+ getCodeActions docB (R 1 0 1 50)
1106+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1107+ executeCodeAction action
1108+ contentAfterAction <- documentContents docB
1109+ liftIO $ contentAfterAction @?= T.unlines (
1110+ ["foo True = select [True]"
1112+ ,"foo False = False"
1114+ , "select :: [Bool] -> Bool"
1115+ , "select = error \"not implemented\""
812fixConstructorImportTests :: TestTree
1120fixConstructorImportTests :: TestTree
813fixConstructorImportTests = testGroup "fix import actions"
1121fixConstructorImportTests = testGroup "fix import actions"
814 [ testSession "fix constructor import" $ template
1122 [ testSession "fix constructor import" $ template
@@ -829,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
831 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
832− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
833− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
834 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
835 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
836 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -849,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
849 [ "module Testing where"
1157 [ "module Testing where"
850 , "import Data.Mape"
1158 , "import Data.Mape"
852− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
853 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
854 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
855 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 ]
@@ -886,10 +1194,10 @@ fillTypedHoleTests = let
886 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
887 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
888 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
889− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
890 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
891 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
892− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
893 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
894 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
895 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -926,36 +1234,37 @@ fillTypedHoleTests = let
927addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
928addSigActionTests = let
1236addSigActionTests = let
929− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
930− moduleH = "module Sigs where"
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
931 before def = T.unlines [header, moduleH, def]
1239 before def = T.unlines [header, moduleH, def]
932 after' def sig = T.unlines [header, moduleH, sig, def]
1240 after' def sig = T.unlines [header, moduleH, sig, def]
934 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
935 let originalCode = before def
1243 let originalCode = before def
936 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
937− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
938 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
939 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
940− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
941 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
942 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
943 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
945 testGroup "add signature"
1253 testGroup "add signature"
946− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
947− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
948− , "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"
949− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
950− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
951− , "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"
954addSigLensesTests :: TestTree
1263addSigLensesTests :: TestTree
955addSigLensesTests = let
1264addSigLensesTests = let
956− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
957 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
958− moduleH = "module Sigs where"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
959 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
960 before withMissing def
1269 before withMissing def
961 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
@@ -965,47 +1274,41 @@ addSigLensesTests = let
965 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
966 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
967 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
968− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
969 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
970 executeCommand c
1279 executeCommand c
971 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
972 liftIO $ expectedCode @=? modifiedCode
1281 liftIO $ expectedCode @=? modifiedCode
974 testGroup "add signature"
1283 testGroup "add signature"
975− [ testGroup "with warnings enabled"
1284+ [ testGroup title
976− [ sigSession True "abc = True" "abc :: Bool"
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
977− , 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"
978− , 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"
979− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
980− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
981− , 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"
982− ]
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
983− , testGroup "with warnings disabled"
984− [ sigSession False "abc = True" "abc :: Bool"
985− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"
986− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
987− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
988− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
989− , 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)
993−findDefinitionAndHoverTests :: TestTree
994−findDefinitionAndHoverTests = let
996− tst (get, check) pos targetRange title = testSession title $ do
997− doc <- openTestDataDoc sourceFilePath
998− found <- get doc pos
999− check found targetRange
1001− checkDefs :: [Location] -> [Expect] -> Session ()
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1002− checkDefs defs expectations = traverse_ check expectations where
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1004− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1005− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1006− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1308+ check ExpectNoDefinitions = do
1309+ assertNDefinitionsFound 0 defs
1007− 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"
1008− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1010 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1011 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1013,23 +1316,35 @@ findDefinitionAndHoverTests = let
1013 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1014 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
1016− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1017− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1019 check expected =
1333 check expected =
1020 case hover of
1334 case hover of
1021− Nothing -> liftIO $ assertFailure "no hover found"
1335+ Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
1022 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1336 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1023 ,_range = rangeInHover } ->
1337 ,_range = rangeInHover } ->
1024 case expected of
1338 case expected of
1025 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1339 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1026 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1027 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1341 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342+ ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
1028 _ -> pure () -- all other expectations not relevant to hover
1343 _ -> pure () -- all other expectations not relevant to hover
1029 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1344 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1031 extractLineColFromHoverMsg :: T.Text -> [T.Text]
1346 extractLineColFromHoverMsg :: T.Text -> [T.Text]
1032− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")
1347+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
1034 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1349 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1035 checkHoverRange expectedRange rangeInHover msg =
1350 checkHoverRange expectedRange rangeInHover msg =
@@ -1056,9 +1371,12 @@ findDefinitionAndHoverTests = let
1057 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1058 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1059− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1061− 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 =
1062 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1063 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1064 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1066,85 +1384,100 @@ findDefinitionAndHoverTests = let
1066 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1068 -- search locations expectations on results
1386 -- search locations expectations on results
1069− 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]
1070− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1071− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1072− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1073− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1074− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1075− 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’"]]
1076− 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"]]
1077− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1078− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1079− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1080− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1081− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1082− 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"]]
1083− 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"]]
1084− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1085− 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’"]]
1086− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1087− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1088− 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]
1089− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1090− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1091− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1092− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1093− ; constr = [ExpectHoverText ["Monad m =>"]]
1412+ ; constr = [ExpectHoverText ["Monad m"]]
1094− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1095− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1096− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1097− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1098− chrL36 = Position 36 25 ; litC = [ExpectHoverText ["'t'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1099− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgv\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1100− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1101− 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]
1102− 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]
1104 mkFindTests
1425 mkFindTests
1105− -- def hover look expect
1426+ -- def hover look expect
1106− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1107− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1108− , 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
1109− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1110− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1111− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1112− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1113− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1114− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1115− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1116− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1117− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1118− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1119− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1120− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1121− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1122− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1123− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1124− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1125− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1126− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1127− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1128− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1129− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1130− , test no broken eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1131− , test no broken intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1132− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1133− , test no broken intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1134− , test no broken chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1135− , test no broken txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1136− , test no broken lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1137− , test no broken docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1138− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1139− , 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)"
1141 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1142 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1143 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1144 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
1146pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1147−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1148 let content =
1481 let content =
1149 T.unlines
1482 T.unlines
1150 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1158,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1158 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1159 , "foo a b = a + c"
1492 , "foo a b = a + c"
1161− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1162 expectDiagnostics
1495 expectDiagnostics
1163 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1164 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1167,26 +1500,39 @@ pluginTests = testSessionWait "plugins" $ do
1168cppTests :: TestTree
1501cppTests :: TestTree
1169cppTests =
1502cppTests =
1170− testCase "cpp" $ do
1504+ [ testCase "cpp-error" $ do
1171− let content =
1505+ let content =
1172− T.unlines
1506+ T.unlines
1173− [ "{-# LANGUAGE CPP #-}",
1507+ [ "{-# LANGUAGE CPP #-}",
1174− "module Testing where",
1508+ "module Testing where",
1175− "#ifdef FOO",
1509+ "#ifdef FOO",
1176− "foo = 42"
1510+ "foo = 42"
1178− -- The error locations differ depending on which C-preprocessor is used.
1512+ -- The error locations differ depending on which C-preprocessor is used.
1179− -- Some give the column number and others don't (hence -1). Assert either
1513+ -- Some give the column number and others don't (hence -1). Assert either
1180− -- of them.
1514+ -- of them.
1181− (run $ expectError content (2, -1))
1515+ (run $ expectError content (2, -1))
1182− `catch` ( \e -> do
1516+ `catch` ( \e -> do
1183− let _ = e :: HUnitFailure
1517+ let _ = e :: HUnitFailure
1184− run $ expectError content (2, 1)
1518+ run $ expectError content (2, 1)
1520+ , testSessionWait "cpp-ghcide" $ do
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1522+ ["{-# LANGUAGE CPP #-}"
1524+ ,"#ifdef __GHCIDE__"
1530+ expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1187 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1188 expectError content cursor = do
1534 expectError content cursor = do
1189− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1190 expectDiagnostics
1536 expectDiagnostics
1191 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1192 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1202,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1202 , "module Testing where"
1548 , "module Testing where"
1203 , "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
1205− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1206 expectDiagnostics
1552 expectDiagnostics
1207 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1208 [(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 ]
1212thTests :: TestTree
1588thTests :: TestTree
1213thTests =
1589thTests =
1214 testGroup
1590 testGroup
@@ -1234,9 +1610,30 @@ thTests =
1234 "b :: Integer",
1610 "b :: Integer",
1235 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1237− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1238− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1239 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616+ , testSessionWait "newtype-closure" $ do
1619+ [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620+ ,"{-# LANGUAGE TemplateHaskell #-}"
1621+ ,"module A (a) where"
1622+ ,"import Data.Data"
1623+ ,"import Language.Haskell.TH"
1624+ ,"newtype A = A () deriving (Data)"
1629+ [ "{-# LANGUAGE TemplateHaskell #-}"
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1242completionTests :: TestTree
1639completionTests :: TestTree
@@ -1244,31 +1641,31 @@ completionTests
1244 = testGroup "completion"
1641 = testGroup "completion"
1245 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1246 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1247− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1248 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1249− liftIO $ map dropDocs compls @?=
1646+ liftIO $ map dropDocs compls @?=
1250 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1251 let [CompletionItem { _documentation = headDocs}] = compls
1648 let [CompletionItem { _documentation = headDocs}] = compls
1252 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1649 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1253−#if MIN_GHC_API_VERSION(8,6,0)
1650+#if MIN_GHC_API_VERSION(8,6,5)
1254 , "Extract the first element of a list"
1651 , "Extract the first element of a list"
1257 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1258 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1259− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1260 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1261− liftIO $ map dropDocs compls @?=
1658+ liftIO $ map dropDocs compls @?=
1262 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
1263#if MIN_GHC_API_VERSION(8,6,0)
1660#if MIN_GHC_API_VERSION(8,6,0)
1264 , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1661 , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1266− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1663+ , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1269 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1270 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 = ()"]
1271− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1272 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1273 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"]]
1274 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1278,25 +1675,51 @@ completionTests
1278 let [ CompletionItem { _documentation = boundedDocs},
1675 let [ CompletionItem { _documentation = boundedDocs},
1279 CompletionItem { _documentation = boolDocs } ] = compls
1676 CompletionItem { _documentation = boolDocs } ] = compls
1280 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1677 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1281−#if MIN_GHC_API_VERSION(8,6,0)
1678+#if MIN_GHC_API_VERSION(8,6,5)
1282 , "name the upper and lower limits"
1679 , "name the upper and lower limits"
1285 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1286 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1287 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 = ()"]
1288− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1289 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1290 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"]]
1291 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
1292− liftIO $ map dropDocs compls @?=
1689+ liftIO $ map dropDocs compls @?=
1293 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1690 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1294 let [CompletionItem { _documentation = headDocs}] = compls
1691 let [CompletionItem { _documentation = headDocs}] = compls
1295 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1692 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1296−#if MIN_GHC_API_VERSION(8,6,0)
1693+#if MIN_GHC_API_VERSION(8,6,5)
1297 , "Extract the first element of a list"
1694 , "Extract the first element of a list"
1697+ , testSessionWait "keyword" $ do
1698+ let source = T.unlines ["module A where", "f = newty"]
1699+ docId <- createDoc "A.hs" "haskell" source
1700+ compls <- getCompletions docId (Position 1 9)
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 "*")]
1302 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1304,6 +1727,7 @@ completionTests
1304 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1305 { _label = label
1728 { _label = label
1306 , _kind = kind
1729 , _kind = kind
1307 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1308 , _documentation = Nothing
1732 , _documentation = Nothing
1309 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1318,6 +1742,24 @@ completionTests
1318 , _command = Nothing
1742 , _command = Nothing
1319 , _xdata = Nothing
1743 , _xdata = Nothing
1745+ keywordItem label = CompletionItem
1747+ , _kind = Just CiKeyword
1749+ , _detail = Nothing
1750+ , _documentation = Nothing
1751+ , _deprecated = Nothing
1752+ , _preselect = Nothing
1753+ , _sortText = Nothing
1754+ , _filterText = Nothing
1755+ , _insertText = Nothing
1756+ , _insertTextFormat = Nothing
1757+ , _textEdit = Nothing
1758+ , _additionalTextEdits = Nothing
1759+ , _commitCharacters = Nothing
1760+ , _command = Nothing
1321 getDocText (CompletionDocString s) = s
1763 getDocText (CompletionDocString s) = s
1322 getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1764 getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1323 checkDocText thing Nothing _
1765 checkDocText thing Nothing _
@@ -1331,7 +1773,7 @@ outlineTests = testGroup
1331 "outline"
1773 "outline"
1332 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1333 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"]
1334− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1335 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1336 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1337 [ moduleSymbol
1779 [ moduleSymbol
@@ -1344,7 +1786,7 @@ outlineTests = testGroup
1345 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1346 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1347− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1348 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1349 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1350 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1352,7 +1794,7 @@ outlineTests = testGroup
1353 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1354 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1355− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1356 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1357 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)]
1358 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1361,7 +1803,7 @@ outlineTests = testGroup
1361 , "type family A a"
1803 , "type family A a"
1362 , "type instance A () = ()"
1804 , "type instance A () = ()"
1364− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1365 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1366 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1367 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1369,7 +1811,7 @@ outlineTests = testGroup
1370 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1371 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1372− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1373 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1374 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)]
1375 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1378,7 +1820,7 @@ outlineTests = testGroup
1378 , "data family A a"
1820 , "data family A a"
1379 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1381− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1382 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1383 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1384 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1386,36 +1828,36 @@ outlineTests = testGroup
1387 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1388 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1389− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1390 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1391 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1392 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1393 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1394 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1395− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1396 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1397 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1398 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1399 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1400 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1401− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1402 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1403 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1404 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1405 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1406 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1407− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1408 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1409 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1410 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1411 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1412− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1413 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1414 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1415 [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)]
1416 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1417 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1418− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1419 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1420 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1421 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1423,18 +1865,47 @@ outlineTests = testGroup
1423 (R 0 0 0 10)
1865 (R 0 0 0 10)
1424 [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)
1426 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1427 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1882+ docId <- createDoc "A.hs" "haskell" source
1883+ symbols <- getDocumentSymbols docId
1884+ liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1891+ , testSessionWait "multiple import" $ do
1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1428− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
1429 symbols <- getDocumentSymbols docId
1894 symbols <- getDocumentSymbols docId
1430 liftIO $ symbols @?= Left
1895 liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1431− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1432 , testSessionWait "foreign import" $ do
1903 , testSessionWait "foreign import" $ do
1433 let source = T.unlines
1904 let source = T.unlines
1434 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1435 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1437− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1438 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1439 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)]
1440 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1442,7 +1913,7 @@ outlineTests = testGroup
1442 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1443 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1445− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1446 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1447 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)]
@@ -1455,6 +1926,8 @@ outlineTests = testGroup
1455 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1456 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1457 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)
1458 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
@@ -1476,16 +1949,247 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1476xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1477xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1479data Expect
1959data Expect
1480 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1481-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1482 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1483 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1484 | ExpectExternFail -- definition lookup in other file expected to fail
1965 | ExpectExternFail -- definition lookup in other file expected to fail
1966+ | ExpectNoDefinitions
1485-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1968-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1487mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1488mkR 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
1977+haddockTests :: TestTree
1979+ = testGroup "haddock"
1980+ [ testCase "Num" $ checkHaddock
1982+ [ "However, '(+)' and '(*)' are"
1983+ , "customarily expected to define a ring and have the following properties:"
1985+ , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986+ , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987+ , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1993+ , "However, `(+)` and `(*)` are"
1994+ , "customarily expected to define a ring and have the following properties: "
1995+ , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996+ , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997+ , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
2000+ , testCase "unsafePerformIO" $ checkHaddock
2003+ , "different precautions:"
2005+ , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006+ , " that calls 'unsafePerformIO'. If the call is inlined,"
2007+ , " the I\\/O may be performed more than once."
2009+ , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010+ , " elimination being performed on the module."
2018+ , "different precautions: "
2019+ , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020+ , " that calls `unsafePerformIO` . If the call is inlined,"
2021+ , " the I/O may be performed more than once."
2023+ , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024+ , " elimination being performed on the module."
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",
1489----------------------------------------------------------------------
2193----------------------------------------------------------------------
@@ -1493,6 +2197,12 @@ mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine st
1493testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1494testSession 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'
1496testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
1497testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
1498 -- 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.
@@ -1503,28 +2213,58 @@ testSessionWait name = testSession name .
1503 -- 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.
1504 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
1506−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
1507−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
1508− [ action
2226+ [ action
1509− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
1510− , title == actionTitle ]
2228+ , title == actionTitle
1512mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
1513mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
1515run :: Session a -> IO a
2234run :: Session a -> IO a
1516−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
1517 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
1519 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
1520 -- 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
1521 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
1523− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
1524 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
1525 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
1526 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
1527− runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2266+ let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
2267+ runSessionWithConfig conf cmd lspTestCaps dir s
1529 conf = defaultConfig
2269 conf = defaultConfig
1530 -- If you uncomment this you can see all logging
2270 -- If you uncomment this you can see all logging
@@ -1536,11 +2276,221 @@ run s = withTempDir $ \dir -> do
1536openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
1537openTestDataDoc path = do
2277openTestDataDoc path = do
1538 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
1539− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
2281+findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282+findCodeActions doc range expectedTitles = do
2283+ actions <- getCodeActions doc range
2284+ let matches = sequence
2287+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288+ , actionTitle == expectedTitle ]
2289+ | expectedTitle <- expectedTitles]
2292+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2294+ ++ " is not a superset of "
2295+ ++ show expectedTitles
2296+ liftIO $ case matches of
2297+ Nothing -> assertFailure msg
2299+ return (fromJust matches)
2301+findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302+findCodeAction doc range t = head <$> findCodeActions doc range [t]
1541unitTests :: TestTree
2304unitTests :: TestTree
1542unitTests = do
2305unitTests = do
1543 testGroup "Unit"
2306 testGroup "Unit"
1544− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
1545− 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 ""
2320+positionMappingTests :: TestTree
2321+positionMappingTests =
2322+ testGroup "position mapping"
2323+ [ testGroup "toCurrent"
2324+ [ testCase "before" $
2326+ (Range (Position 0 1) (Position 0 3))
2328+ (Position 0 0) @?= Just (Position 0 0)
2329+ , testCase "after, same line, same length" $
2331+ (Range (Position 0 1) (Position 0 3))
2333+ (Position 0 3) @?= Just (Position 0 3)
2334+ , testCase "after, same line, increased length" $
2336+ (Range (Position 0 1) (Position 0 3))
2338+ (Position 0 3) @?= Just (Position 0 4)
2339+ , testCase "after, same line, decreased length" $
2341+ (Range (Position 0 1) (Position 0 3))
2343+ (Position 0 3) @?= Just (Position 0 2)
2344+ , testCase "after, next line, no newline" $
2346+ (Range (Position 0 1) (Position 0 3))
2348+ (Position 1 3) @?= Just (Position 1 3)
2349+ , testCase "after, next line, newline" $
2351+ (Range (Position 0 1) (Position 0 3))
2353+ (Position 1 0) @?= Just (Position 2 0)
2354+ , testCase "after, same line, newline" $
2356+ (Range (Position 0 1) (Position 0 3))
2358+ (Position 0 4) @?= Just (Position 1 2)
2359+ , testCase "after, same line, newline + newline at end" $
2361+ (Range (Position 0 1) (Position 0 3))
2363+ (Position 0 4) @?= Just (Position 2 1)
2364+ , testCase "after, same line, newline + newline at end" $
2366+ (Range (Position 0 1) (Position 0 1))
2368+ (Position 0 1) @?= Just (Position 0 4)
2370+ , testGroup "fromCurrent"
2371+ [ testCase "before" $
2373+ (Range (Position 0 1) (Position 0 3))
2375+ (Position 0 0) @?= Just (Position 0 0)
2376+ , testCase "after, same line, same length" $
2378+ (Range (Position 0 1) (Position 0 3))
2380+ (Position 0 3) @?= Just (Position 0 3)
2381+ , testCase "after, same line, increased length" $
2383+ (Range (Position 0 1) (Position 0 3))
2385+ (Position 0 4) @?= Just (Position 0 3)
2386+ , testCase "after, same line, decreased length" $
2388+ (Range (Position 0 1) (Position 0 3))
2390+ (Position 0 2) @?= Just (Position 0 3)
2391+ , testCase "after, next line, no newline" $
2393+ (Range (Position 0 1) (Position 0 3))
2395+ (Position 1 3) @?= Just (Position 1 3)
2396+ , testCase "after, next line, newline" $
2398+ (Range (Position 0 1) (Position 0 3))
2400+ (Position 2 0) @?= Just (Position 1 0)
2401+ , testCase "after, same line, newline" $
2403+ (Range (Position 0 1) (Position 0 3))
2405+ (Position 1 2) @?= Just (Position 0 4)
2406+ , testCase "after, same line, newline + newline at end" $
2408+ (Range (Position 0 1) (Position 0 3))
2410+ (Position 2 1) @?= Just (Position 0 4)
2411+ , testCase "after, same line, newline + newline at end" $
2413+ (Range (Position 0 1) (Position 0 1))
2415+ (Position 0 4) @?= Just (Position 0 1)
2417+ , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
2418+ [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
2419+ -- Note that it is important to use suchThatMap on all values at once
2420+ -- instead of only using it on the position. Otherwise you can get
2421+ -- into situations where there is no position that can be mapped back
2422+ -- for the edit which will result in QuickCheck looping forever.
2425+ range <- genRange rope
2426+ PrintableText replacement <- arbitrary
2427+ oldPos <- genPosition rope
2428+ pure (range, replacement, oldPos)
2431+ (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
2432+ \(range, replacement, oldPos, newPos) ->
2433+ fromCurrent range replacement newPos === Just oldPos
2434+ , testProperty "toCurrent r t <=< fromCurrent r t" $ do
2437+ range <- genRange rope
2438+ PrintableText replacement <- arbitrary
2439+ let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
2440+ newPos <- genPosition newRope
2441+ pure (range, replacement, newPos)
2444+ (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445+ \(range, replacement, newPos, oldPos) ->
2446+ toCurrent range replacement oldPos === Just newPos
2450+newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2453+instance Arbitrary PrintableText where
2454+ arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2458+genRope = Rope.fromText . getPrintableText <$> arbitrary
2460+genPosition :: Rope -> Gen Position
2462+ row <- choose (0, max 0 $ rows - 1)
2463+ let columns = Rope.columns (nthLine row r)
2464+ column <- choose (0, max 0 $ columns - 1)
2465+ pure $ Position row column
2466+ where rows = Rope.rows r
2468+genRange :: Rope -> Gen Range
2470+ startPos@(Position startLine startColumn) <- genPosition r
2471+ let maxLineDiff = max 0 $ rows - 1 - startLine
2472+ endLine <- choose (startLine, startLine + maxLineDiff)
2473+ let columns = Rope.columns (nthLine endLine r)
2475+ if startLine == endLine
2476+ then choose (startColumn, columns)
2477+ else choose (0, max 0 $ columns - 1)
2478+ pure $ Range startPos (Position endLine endColumn)
2479+ where rows = Rope.rows r
2481+-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482+nthLine :: Int -> Rope -> Rope
2484+ | i < 0 = error $ "Negative line number: " <> show i
2485+ | i == 0 && Rope.rows r == 0 = r
2486+ | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows 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