test/exe/Main.hs · ghcide

git.iko.soy/ghcide

on debugging help sign in

ghcide/test/exe/Main.hs

1546 lines 65 kB history raw

2-- SPDX-License-Identifier: Apache-2.0

4{-# LANGUAGE DuplicateRecordFields #-}

5{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE CPP #-}

7#include "ghc-api-version.h"

9module Main (main) where

11import Control.Applicative.Combinators

12import Control.Exception (catch)

13import Control.Monad

14import Control.Monad.IO.Class (liftIO)

15import Data.Char (toLower)

16import Data.Foldable

17import Data.List

18import Development.IDE.GHC.Util

19import qualified Data.Text as T

20import Development.IDE.Test

21import Development.IDE.Test.Runfiles

22import Development.IDE.Types.Location

23import Language.Haskell.LSP.Test

24import Language.Haskell.LSP.Types

25import Language.Haskell.LSP.Types.Capabilities

26import System.Environment.Blank (setEnv)

27import System.FilePath

28import System.IO.Extra

29import System.Directory

30import Test.Tasty

31import Test.Tasty.HUnit

32import Test.Tasty.ExpectedFailure

33import Data.Maybe

35main :: IO ()

36main = defaultMain $ testGroup "HIE"

37 [ testSession "open close" $ do

38 doc <- openDoc' "Testing.hs" "haskell" ""

39 void (message :: Session WorkDoneProgressCreateRequest)

40 void (message :: Session WorkDoneProgressBeginNotification)

41 closeDoc doc

42 void (message :: Session WorkDoneProgressEndNotification)

43 , initializeResponseTests

44 , completionTests

45 , cppTests

46 , diagnosticTests

47 , codeActionTests

48 , codeLensesTests

49 , outlineTests

50 , findDefinitionAndHoverTests

51 , pluginTests

52 , preprocessorTests

53 , thTests

54 , unitTests

55 ]

57initializeResponseTests :: TestTree

58initializeResponseTests = withResource acquire release tests where

60 -- these tests document and monitor the evolution of the

61 -- capabilities announced by the server in the initialize

62 -- response. Currently the server advertises almost no capabilities

63 -- at all, in some cases failing to announce capabilities that it

64 -- actually does provide! Hopefully this will change ...

65 tests :: IO InitializeResponse -> TestTree

66 tests getInitializeResponse =

67 testGroup "initialize response capabilities"

68 [ chk " text doc sync" _textDocumentSync tds

69 , chk " hover" _hoverProvider (Just True)

70 , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)

71 , chk "NO signature help" _signatureHelpProvider Nothing

72 , chk " goto definition" _definitionProvider (Just True)

73 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)

74 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)

75 , chk "NO find references" _referencesProvider Nothing

76 , chk "NO doc highlight" _documentHighlightProvider Nothing

77 , chk " doc symbol" _documentSymbolProvider (Just True)

78 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing

79 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True

80 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing

81 , chk "NO doc formatting" _documentFormattingProvider Nothing

82 , chk "NO doc range formatting"

83 _documentRangeFormattingProvider Nothing

84 , chk "NO doc formatting on typing"

85 _documentOnTypeFormattingProvider Nothing

86 , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False)

87 , chk "NO doc link" _documentLinkProvider Nothing

88 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

89 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

90 , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

91 , chk "NO workspace" _workspace nothingWorkspace

92 , chk "NO experimental" _experimental Nothing

93 ] where

95 tds = Just (TDSOptions (TextDocumentSyncOptions

96 { _openClose = Just True

97 , _change = Just TdSyncIncremental

98 , _willSave = Nothing

99 , _willSaveWaitUntil = Nothing

100 , _save = Just (SaveOptions {_includeText = Nothing})}))

101

102 nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

103

104 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

105 chk title getActual expected =

106 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

107

108 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

109 innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

110 innerCaps _ = error "this test only expects inner capabilities"

111

112 acquire :: IO InitializeResponse

113 acquire = run initializeResponse

114

115 release :: InitializeResponse -> IO ()

116 release = const $ pure ()

117

118

119diagnosticTests :: TestTree

120diagnosticTests = testGroup "diagnostics"

121 [ testSessionWait "fix syntax error" $ do

122 let content = T.unlines [ "module Testing wher" ]

123 doc <- openDoc' "Testing.hs" "haskell" content

124 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

125 let change = TextDocumentContentChangeEvent

126 { _range = Just (Range (Position 0 15) (Position 0 19))

127 , _rangeLength = Nothing

128 , _text = "where"

129 }

130 changeDoc doc [change]

131 expectDiagnostics [("Testing.hs", [])]

132 , testSessionWait "introduce syntax error" $ do

133 let content = T.unlines [ "module Testing where" ]

134 doc <- openDoc' "Testing.hs" "haskell" content

135 void (message :: Session WorkDoneProgressCreateRequest)

136 void (message :: Session WorkDoneProgressBeginNotification)

137 let change = TextDocumentContentChangeEvent

138 { _range = Just (Range (Position 0 15) (Position 0 18))

139 , _rangeLength = Nothing

140 , _text = "wher"

141 }

142 changeDoc doc [change]

143 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

144 , testSessionWait "variable not in scope" $ do

145 let content = T.unlines

146 [ "module Testing where"

147 , "foo :: Int -> Int -> Int"

148 , "foo a b = a + ab"

149 , "bar :: Int -> Int -> Int"

150 , "bar a b = cd + b"

151 ]

152 _ <- openDoc' "Testing.hs" "haskell" content

153 expectDiagnostics

154 [ ( "Testing.hs"

155 , [ (DsError, (2, 14), "Variable not in scope: ab")

156 , (DsError, (4, 10), "Variable not in scope: cd")

157 ]

158 )

159 ]

160 , testSessionWait "type error" $ do

161 let content = T.unlines

162 [ "module Testing where"

163 , "foo :: Int -> String -> Int"

164 , "foo a b = a + b"

165 ]

166 _ <- openDoc' "Testing.hs" "haskell" content

167 expectDiagnostics

168 [ ( "Testing.hs"

169 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

170 )

171 ]

172 , testSessionWait "typed hole" $ do

173 let content = T.unlines

174 [ "module Testing where"

175 , "foo :: Int -> String"

176 , "foo a = _ a"

177 ]

178 _ <- openDoc' "Testing.hs" "haskell" content

179 expectDiagnostics

180 [ ( "Testing.hs"

181 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

182 )

183 ]

184

185 , testGroup "deferral" $

186 let sourceA a = T.unlines

187 [ "module A where"

188 , "a :: Int"

189 , "a = " <> a]

190 sourceB = T.unlines

191 [ "module B where"

192 , "import A"

193 , "b :: Float"

194 , "b = True"]

195 bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"

196 expectedDs aMessage =

197 [ ("A.hs", [(DsError, (2,4), aMessage)])

198 , ("B.hs", [(DsError, (3,4), bMessage)])]

199 deferralTest title binding msg = testSessionWait title $ do

200 _ <- openDoc' "A.hs" "haskell" $ sourceA binding

201 _ <- openDoc' "B.hs" "haskell" sourceB

202 expectDiagnostics $ expectedDs msg

203 in

204 [ deferralTest "type error" "True" "Couldn't match expected type"

205 , deferralTest "typed hole" "_" "Found hole"

206 , deferralTest "out of scope var" "unbound" "Variable not in scope"

207 , deferralTest "message shows error" "True" "A.hs:3:5: error:"

208 ]

209

210 , testSessionWait "remove required module" $ do

211 let contentA = T.unlines [ "module ModuleA where" ]

212 docA <- openDoc' "ModuleA.hs" "haskell" contentA

213 let contentB = T.unlines

214 [ "module ModuleB where"

215 , "import ModuleA"

216 ]

217 _ <- openDoc' "ModuleB.hs" "haskell" contentB

218 let change = TextDocumentContentChangeEvent

219 { _range = Just (Range (Position 0 0) (Position 0 20))

220 , _rangeLength = Nothing

221 , _text = ""

222 }

223 changeDoc docA [change]

224 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]

225 , testSessionWait "add missing module" $ do

226 let contentB = T.unlines

227 [ "module ModuleB where"

228 , "import ModuleA"

229 ]

230 _ <- openDoc' "ModuleB.hs" "haskell" contentB

231 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

232 let contentA = T.unlines [ "module ModuleA where" ]

233 _ <- openDoc' "ModuleA.hs" "haskell" contentA

234 expectDiagnostics [("ModuleB.hs", [])]

235 , testSessionWait "cyclic module dependency" $ do

236 let contentA = T.unlines

237 [ "module ModuleA where"

238 , "import ModuleB"

239 ]

240 let contentB = T.unlines

241 [ "module ModuleB where"

242 , "import ModuleA"

243 ]

244 _ <- openDoc' "ModuleA.hs" "haskell" contentA

245 _ <- openDoc' "ModuleB.hs" "haskell" contentB

246 expectDiagnostics

247 [ ( "ModuleA.hs"

248 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

249 )

250 , ( "ModuleB.hs"

251 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

252 )

253 ]

254 , testSessionWait "cyclic module dependency with hs-boot" $ do

255 let contentA = T.unlines

256 [ "module ModuleA where"

257 , "import {-# SOURCE #-} ModuleB"

258 ]

259 let contentB = T.unlines

260 [ "module ModuleB where"

261 , "import ModuleA"

262 ]

263 let contentBboot = T.unlines

264 [ "module ModuleB where"

265 ]

266 _ <- openDoc' "ModuleA.hs" "haskell" contentA

267 _ <- openDoc' "ModuleB.hs" "haskell" contentB

268 _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

269 expectDiagnostics []

270 , testSessionWait "correct reference used with hs-boot" $ do

271 let contentB = T.unlines

272 [ "module ModuleB where"

273 , "import {-# SOURCE #-} ModuleA"

274 ]

275 let contentA = T.unlines

276 [ "module ModuleA where"

277 , "import ModuleB"

278 , "x = 5"

279 ]

280 let contentAboot = T.unlines

281 [ "module ModuleA where"

282 ]

283 let contentC = T.unlines

284 [ "module ModuleC where"

285 , "import ModuleA"

286 -- this reference will fail if it gets incorrectly

287 -- resolved to the hs-boot file

288 , "y = x"

289 ]

290 _ <- openDoc' "ModuleB.hs" "haskell" contentB

291 _ <- openDoc' "ModuleA.hs" "haskell" contentA

292 _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

293 _ <- openDoc' "ModuleC.hs" "haskell" contentC

294 expectDiagnostics []

295 , testSessionWait "redundant import" $ do

296 let contentA = T.unlines ["module ModuleA where"]

297 let contentB = T.unlines

298 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

299 , "module ModuleB where"

300 , "import ModuleA"

301 ]

302 _ <- openDoc' "ModuleA.hs" "haskell" contentA

303 _ <- openDoc' "ModuleB.hs" "haskell" contentB

304 expectDiagnostics

305 [ ( "ModuleB.hs"

306 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

307 )

308 ]

309 , testSessionWait "package imports" $ do

310 let thisDataListContent = T.unlines

311 [ "module Data.List where"

312 , "x :: Integer"

313 , "x = 123"

314 ]

315 let mainContent = T.unlines

316 [ "{-# LANGUAGE PackageImports #-}"

317 , "module Main where"

318 , "import qualified \"this\" Data.List as ThisList"

319 , "import qualified \"base\" Data.List as BaseList"

320 , "useThis = ThisList.x"

321 , "useBase = BaseList.map"

322 , "wrong1 = ThisList.map"

323 , "wrong2 = BaseList.x"

324 ]

325 _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

326 _ <- openDoc' "Main.hs" "haskell" mainContent

327 expectDiagnostics

328 [ ( "Main.hs"

329 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

330 ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")

331 ]

332 )

333 ]

334 , testSessionWait "unqualified warnings" $ do

335 let fooContent = T.unlines

336 [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"

337 , "module Foo where"

338 , "foo :: Ord a => a -> Int"

339 , "foo a = 1"

340 ]

341 _ <- openDoc' "Foo.hs" "haskell" fooContent

342 expectDiagnostics

343 [ ( "Foo.hs"

344 -- The test is to make sure that warnings contain unqualified names

345 -- where appropriate. The warning should use an unqualified name 'Ord', not

346 -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to

347 -- test this is fairly arbitrary.

348 , [(DsWarning, (2, 0), "Redundant constraint: Ord a")

349 ]

350 )

351 ]

352 , testSessionWait "lower-case drive" $ do

353 let aContent = T.unlines

354 [ "module A.A where"

355 , "import A.B ()"

356 ]

357 bContent = T.unlines

358 [ "{-# OPTIONS_GHC -Wall #-}"

359 , "module A.B where"

360 , "import Data.List"

361 ]

362 uriB <- getDocUri "A/B.hs"

363 Just pathB <- pure $ uriToFilePath uriB

364 uriB <- pure $

365 let (drive, suffix) = splitDrive pathB

366 in filePathToUri (joinDrive (map toLower drive ) suffix)

367 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

368 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

369 uriA <- getDocUri "A/A.hs"

370 Just pathA <- pure $ uriToFilePath uriA

371 uriA <- pure $

372 let (drive, suffix) = splitDrive pathA

373 in filePathToUri (joinDrive (map toLower drive ) suffix)

374 let itemA = TextDocumentItem uriA "haskell" 0 aContent

375 let a = TextDocumentIdentifier uriA

376 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

377 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

378 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

379 -- Check that if we put a lower-case drive in for A.A

380 -- the diagnostics for A.B will also be lower-case.

381 liftIO $ fileUri @?= uriB

382 let msg = _message (head (toList diags) :: Diagnostic)

383 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

384 assertFailure ("Expected redundant import but got " <> T.unpack msg)

385 closeDoc a

386 ]

387

388codeActionTests :: TestTree

389codeActionTests = testGroup "code actions"

390 [ renameActionTests

391 , typeWildCardActionTests

392 , removeImportTests

393 , extendImportTests

394 , fixConstructorImportTests

395 , importRenameActionTests

396 , fillTypedHoleTests

397 , addSigActionTests

398 ]

399

400codeLensesTests :: TestTree

401codeLensesTests = testGroup "code lenses"

402 [ addSigLensesTests

403 ]

404

405renameActionTests :: TestTree

406renameActionTests = testGroup "rename actions"

407 [ testSession "change to local variable name" $ do

408 let content = T.unlines

409 [ "module Testing where"

410 , "foo :: Int -> Int"

411 , "foo argName = argNme"

412 ]

413 doc <- openDoc' "Testing.hs" "haskell" content

414 _ <- waitForDiagnostics

415 [CACodeAction action@CodeAction { _title = actionTitle }]

416 <- getCodeActions doc (Range (Position 2 14) (Position 2 20))

417 liftIO $ "Replace with ‘argName’" @=? actionTitle

418 executeCodeAction action

419 contentAfterAction <- documentContents doc

420 let expectedContentAfterAction = T.unlines

421 [ "module Testing where"

422 , "foo :: Int -> Int"

423 , "foo argName = argName"

424 ]

425 liftIO $ expectedContentAfterAction @=? contentAfterAction

426 , testSession "change to name of imported function" $ do

427 let content = T.unlines

428 [ "module Testing where"

429 , "import Data.Maybe (maybeToList)"

430 , "foo :: Maybe a -> [a]"

431 , "foo = maybToList"

432 ]

433 doc <- openDoc' "Testing.hs" "haskell" content

434 _ <- waitForDiagnostics

435 [CACodeAction action@CodeAction { _title = actionTitle }]

436 <- getCodeActions doc (Range (Position 3 6) (Position 3 16))

437 liftIO $ "Replace with ‘maybeToList’" @=? actionTitle

438 executeCodeAction action

439 contentAfterAction <- documentContents doc

440 let expectedContentAfterAction = T.unlines

441 [ "module Testing where"

442 , "import Data.Maybe (maybeToList)"

443 , "foo :: Maybe a -> [a]"

444 , "foo = maybeToList"

445 ]

446 liftIO $ expectedContentAfterAction @=? contentAfterAction

447 , testSession "suggest multiple local variable names" $ do

448 let content = T.unlines

449 [ "module Testing where"

450 , "foo :: Char -> Char -> Char -> Char"

451 , "foo argument1 argument2 argument3 = argumentX"

452 ]

453 doc <- openDoc' "Testing.hs" "haskell" content

454 _ <- waitForDiagnostics

455 actionsOrCommands <- getCodeActions 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’"]

458 liftIO $ expectedActionTitles @=? actionTitles

459 , testSession "change infix function" $ do

460 let content = T.unlines

461 [ "module Testing where"

462 , "monus :: Int -> Int"

463 , "monus x y = max 0 (x - y)"

464 , "foo x y = x `monnus` y"

465 ]

466 doc <- openDoc' "Testing.hs" "haskell" content

467 _ <- waitForDiagnostics

468 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

469 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

470 executeCodeAction fixTypo

471 contentAfterAction <- documentContents doc

472 let expectedContentAfterAction = T.unlines

473 [ "module Testing where"

474 , "monus :: Int -> Int"

475 , "monus x y = max 0 (x - y)"

476 , "foo x y = x `monus` y"

477 ]

478 liftIO $ expectedContentAfterAction @=? contentAfterAction

479 ]

480

481typeWildCardActionTests :: TestTree

482typeWildCardActionTests = testGroup "type wildcard actions"

483 [ testSession "global signature" $ do

484 let content = T.unlines

485 [ "module Testing where"

486 , "func :: _"

487 , "func x = x"

488 ]

489 doc <- openDoc' "Testing.hs" "haskell" content

490 _ <- waitForDiagnostics

491 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

492 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

493 , "Use type signature" `T.isInfixOf` actionTitle

494 ]

495 executeCodeAction addSignature

496 contentAfterAction <- documentContents doc

497 let expectedContentAfterAction = T.unlines

498 [ "module Testing where"

499 , "func :: (p -> p)"

500 , "func x = x"

501 ]

502 liftIO $ expectedContentAfterAction @=? contentAfterAction

503 , testSession "multi-line message" $ do

504 let content = T.unlines

505 [ "module Testing where"

506 , "func :: _"

507 , "func x y = x + y"

508 ]

509 doc <- openDoc' "Testing.hs" "haskell" content

510 _ <- waitForDiagnostics

511 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

512 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

513 , "Use type signature" `T.isInfixOf` actionTitle

514 ]

515 executeCodeAction addSignature

516 contentAfterAction <- documentContents doc

517 let expectedContentAfterAction = T.unlines

518 [ "module Testing where"

519 , "func :: (Integer -> Integer -> Integer)"

520 , "func x y = x + y"

521 ]

522 liftIO $ expectedContentAfterAction @=? contentAfterAction

523 , testSession "local signature" $ do

524 let content = T.unlines

525 [ "module Testing where"

526 , "func :: Int -> Int"

527 , "func x ="

528 , " let y :: _"

529 , " y = x * 2"

530 , " in y"

531 ]

532 doc <- openDoc' "Testing.hs" "haskell" content

533 _ <- waitForDiagnostics

534 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

535 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

536 , "Use type signature" `T.isInfixOf` actionTitle

537 ]

538 executeCodeAction addSignature

539 contentAfterAction <- documentContents doc

540 let expectedContentAfterAction = T.unlines

541 [ "module Testing where"

542 , "func :: Int -> Int"

543 , "func x ="

544 , " let y :: (Int)"

545 , " y = x * 2"

546 , " in y"

547 ]

548 liftIO $ expectedContentAfterAction @=? contentAfterAction

549 ]

550

551removeImportTests :: TestTree

552removeImportTests = testGroup "remove import actions"

553 [ testSession "redundant" $ do

554 let contentA = T.unlines

555 [ "module ModuleA where"

556 ]

557 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

558 let contentB = T.unlines

559 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

560 , "module ModuleB where"

561 , "import ModuleA"

562 , "stuffB :: Integer"

563 , "stuffB = 123"

564 ]

565 docB <- openDoc' "ModuleB.hs" "haskell" contentB

566 _ <- waitForDiagnostics

567 [CACodeAction action@CodeAction { _title = actionTitle }]

568 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

569 liftIO $ "Remove import" @=? actionTitle

570 executeCodeAction action

571 contentAfterAction <- documentContents docB

572 let expectedContentAfterAction = T.unlines

573 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

574 , "module ModuleB where"

575 , "stuffB :: Integer"

576 , "stuffB = 123"

577 ]

578 liftIO $ expectedContentAfterAction @=? contentAfterAction

579 , testSession "qualified redundant" $ do

580 let contentA = T.unlines

581 [ "module ModuleA where"

582 ]

583 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

584 let contentB = T.unlines

585 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

586 , "module ModuleB where"

587 , "import qualified ModuleA"

588 , "stuffB :: Integer"

589 , "stuffB = 123"

590 ]

591 docB <- openDoc' "ModuleB.hs" "haskell" contentB

592 _ <- waitForDiagnostics

593 [CACodeAction action@CodeAction { _title = actionTitle }]

594 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

595 liftIO $ "Remove import" @=? actionTitle

596 executeCodeAction action

597 contentAfterAction <- documentContents docB

598 let expectedContentAfterAction = T.unlines

599 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

600 , "module ModuleB where"

601 , "stuffB :: Integer"

602 , "stuffB = 123"

603 ]

604 liftIO $ expectedContentAfterAction @=? contentAfterAction

605 , testSession "redundant binding" $ do

606 let contentA = T.unlines

607 [ "module ModuleA where"

608 , "stuffA = False"

609 , "stuffB :: Integer"

610 , "stuffB = 123"

611 , "stuffC = ()"

612 ]

613 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

614 let contentB = T.unlines

615 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

616 , "module ModuleB where"

617 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

618 , "main = print stuffB"

619 ]

620 docB <- openDoc' "ModuleB.hs" "haskell" contentB

621 _ <- waitForDiagnostics

622 [CACodeAction action@CodeAction { _title = actionTitle }]

623 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

624 liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle

625 executeCodeAction action

626 contentAfterAction <- documentContents docB

627 let expectedContentAfterAction = T.unlines

628 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

629 , "module ModuleB where"

630 , "import ModuleA (stuffB)"

631 , "main = print stuffB"

632 ]

633 liftIO $ expectedContentAfterAction @=? contentAfterAction

634 , testSession "redundant symbol binding" $ do

635 let contentA = T.unlines

636 [ "module ModuleA where"

637 , "a !! b = a"

638 , "stuffB :: Integer"

639 , "stuffB = 123"

640 ]

641 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

642 let contentB = T.unlines

643 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

644 , "module ModuleB where"

645 , "import qualified ModuleA as A ((!!), stuffB, (!!))"

646 , "main = print A.stuffB"

647 ]

648 docB <- openDoc' "ModuleB.hs" "haskell" contentB

649 _ <- waitForDiagnostics

650 [CACodeAction action@CodeAction { _title = actionTitle }]

651 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

652#if MIN_GHC_API_VERSION(8,6,0)

653 liftIO $ "Remove !! from import" @=? actionTitle

654#else

655 liftIO $ "Remove A.!! from import" @=? actionTitle

656#endif

657 executeCodeAction action

658 contentAfterAction <- documentContents docB

659 let expectedContentAfterAction = T.unlines

660 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

661 , "module ModuleB where"

662 , "import qualified ModuleA as A (stuffB)"

663 , "main = print A.stuffB"

664 ]

665 liftIO $ expectedContentAfterAction @=? contentAfterAction

666 , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do

667 let contentA = T.unlines

668 [ "module ModuleA where"

669 , "data A = A"

670 , "stuffB :: Integer"

671 , "stuffB = 123"

672 ]

673 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

674 let contentB = T.unlines

675 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

676 , "module ModuleB where"

677 , "import ModuleA (A(..), stuffB)"

678 , "main = print stuffB"

679 ]

680 docB <- openDoc' "ModuleB.hs" "haskell" contentB

681 _ <- waitForDiagnostics

682 [CACodeAction action@CodeAction { _title = actionTitle }]

683 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

684 liftIO $ "Remove A from import" @=? actionTitle

685 executeCodeAction action

686 contentAfterAction <- documentContents docB

687 let expectedContentAfterAction = T.unlines

688 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

689 , "module ModuleB where"

690 , "import ModuleA (stuffB)"

691 , "main = print stuffB"

692 ]

693 liftIO $ expectedContentAfterAction @=? contentAfterAction

694 ]

695

696extendImportTests :: TestTree

697extendImportTests = testGroup "extend import actions"

698 [ testSession "extend single line import with value" $ template

699 (T.unlines

700 [ "module ModuleA where"

701 , "stuffA :: Double"

702 , "stuffA = 0.00750"

703 , "stuffB :: Integer"

704 , "stuffB = 123"

705 ])

706 (T.unlines

707 [ "module ModuleB where"

708 , "import ModuleA as A (stuffB)"

709 , "main = print (stuffA, stuffB)"

710 ])

711 (Range (Position 3 17) (Position 3 18))

712 "Add stuffA to the import list of ModuleA"

713 (T.unlines

714 [ "module ModuleB where"

715 , "import ModuleA as A (stuffA, stuffB)"

716 , "main = print (stuffA, stuffB)"

717 ])

718 , testSession "extend single line import with type" $ template

719 (T.unlines

720 [ "module ModuleA where"

721 , "type A = Double"

722 ])

723 (T.unlines

724 [ "module ModuleB where"

725 , "import ModuleA ()"

726 , "b :: A"

727 , "b = 0"

728 ])

729 (Range (Position 2 5) (Position 2 5))

730 "Add A to the import list of ModuleA"

731 (T.unlines

732 [ "module ModuleB where"

733 , "import ModuleA (A)"

734 , "b :: A"

735 , "b = 0"

736 ])

737 , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template

738 (T.unlines

739 [ "module ModuleA where"

740 , "data A = Constructor"

741 ])

742 (T.unlines

743 [ "module ModuleB where"

744 , "import ModuleA (A)"

745 , "b :: A"

746 , "b = Constructor"

747 ])

748 (Range (Position 2 5) (Position 2 5))

749 "Add Constructor to the import list of ModuleA"

750 (T.unlines

751 [ "module ModuleB where"

752 , "import ModuleA (A(Constructor))"

753 , "b :: A"

754 , "b = Constructor"

755 ])

756 , testSession "extend single line qualified import with value" $ template

757 (T.unlines

758 [ "module ModuleA where"

759 , "stuffA :: Double"

760 , "stuffA = 0.00750"

761 , "stuffB :: Integer"

762 , "stuffB = 123"

763 ])

764 (T.unlines

765 [ "module ModuleB where"

766 , "import qualified ModuleA as A (stuffB)"

767 , "main = print (A.stuffA, A.stuffB)"

768 ])

769 (Range (Position 3 17) (Position 3 18))

770 "Add stuffA to the import list of ModuleA"

771 (T.unlines

772 [ "module ModuleB where"

773 , "import qualified ModuleA as A (stuffA, stuffB)"

774 , "main = print (A.stuffA, A.stuffB)"

775 ])

776 , testSession "extend multi line import with value" $ template

777 (T.unlines

778 [ "module ModuleA where"

779 , "stuffA :: Double"

780 , "stuffA = 0.00750"

781 , "stuffB :: Integer"

782 , "stuffB = 123"

783 ])

784 (T.unlines

785 [ "module ModuleB where"

786 , "import ModuleA (stuffB"

787 , " )"

788 , "main = print (stuffA, stuffB)"

789 ])

790 (Range (Position 3 17) (Position 3 18))

791 "Add stuffA to the import list of ModuleA"

792 (T.unlines

793 [ "module ModuleB where"

794 , "import ModuleA (stuffA, stuffB"

795 , " )"

796 , "main = print (stuffA, stuffB)"

797 ])

798 ]

799 where

800 template contentA contentB range expectedAction expectedContentB = do

801 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

802 docB <- openDoc' "ModuleB.hs" "haskell" contentB

803 _ <- waitForDiagnostics

804 CACodeAction action@CodeAction { _title = actionTitle } : _

805 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

806 getCodeActions docB range

807 liftIO $ expectedAction @=? actionTitle

808 executeCodeAction action

809 contentAfterAction <- documentContents docB

810 liftIO $ expectedContentB @=? contentAfterAction

811

812fixConstructorImportTests :: TestTree

813fixConstructorImportTests = testGroup "fix import actions"

814 [ testSession "fix constructor import" $ template

815 (T.unlines

816 [ "module ModuleA where"

817 , "data A = Constructor"

818 ])

819 (T.unlines

820 [ "module ModuleB where"

821 , "import ModuleA(Constructor)"

822 ])

823 (Range (Position 1 10) (Position 1 11))

824 "Fix import of A(Constructor)"

825 (T.unlines

826 [ "module ModuleB where"

827 , "import ModuleA(A(Constructor))"

828 ])

829 ]

830 where

831 template contentA contentB range expectedAction expectedContentB = do

832 _docA <- openDoc' "ModuleA.hs" "haskell" contentA

833 docB <- openDoc' "ModuleB.hs" "haskell" contentB

834 _diags <- waitForDiagnostics

835 CACodeAction action@CodeAction { _title = actionTitle } : _

836 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

837 getCodeActions docB range

838 liftIO $ expectedAction @=? actionTitle

839 executeCodeAction action

840 contentAfterAction <- documentContents docB

841 liftIO $ expectedContentB @=? contentAfterAction

842

843importRenameActionTests :: TestTree

844importRenameActionTests = testGroup "import rename actions"

845 [ testSession "Data.Mape -> Data.Map" $ check "Map"

846 , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where

847 check modname = do

848 let content = T.unlines

849 [ "module Testing where"

850 , "import Data.Mape"

851 ]

852 doc <- openDoc' "Testing.hs" "haskell" content

853 _ <- waitForDiagnostics

854 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 ]

856 executeCodeAction changeToMap

857 contentAfterAction <- documentContents doc

858 let expectedContentAfterAction = T.unlines

859 [ "module Testing where"

860 , "import Data." <> modname

861 ]

862 liftIO $ expectedContentAfterAction @=? contentAfterAction

863

864fillTypedHoleTests :: TestTree

865fillTypedHoleTests = let

866

867 sourceCode :: T.Text -> T.Text -> T.Text -> T.Text

868 sourceCode a b c = T.unlines

869 [ "module Testing where"

870 , ""

871 , "globalConvert :: Int -> String"

872 , "globalConvert = undefined"

873 , ""

874 , "globalInt :: Int"

875 , "globalInt = 3"

876 , ""

877 , "bar :: Int -> Int -> String"

878 , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"

879 , " localConvert = (flip replicate) 'x'"

880

881 ]

882

883 check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree

884 check actionTitle

885 oldA oldB oldC

886 newA newB newC = testSession (T.unpack actionTitle) $ do

887 let originalCode = sourceCode oldA oldB oldC

888 let expectedCode = sourceCode newA newB newC

889 doc <- openDoc' "Testing.hs" "haskell" originalCode

890 _ <- waitForDiagnostics

891 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

892 let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

893 executeCodeAction chosenAction

894 modifiedCode <- documentContents doc

895 liftIO $ expectedCode @=? modifiedCode

896 in

897 testGroup "fill typed holes"

898 [ check "replace hole `_` with show"

899 "_" "n" "n"

900 "show" "n" "n"

901

902 , check "replace hole `_` with globalConvert"

903 "_" "n" "n"

904 "globalConvert" "n" "n"

905

906#if MIN_GHC_API_VERSION(8,6,0)

907 , check "replace hole `_convertme` with localConvert"

908 "_convertme" "n" "n"

909 "localConvert" "n" "n"

910#endif

911

912 , check "replace hole `_b` with globalInt"

913 "_a" "_b" "_c"

914 "_a" "globalInt" "_c"

915

916 , check "replace hole `_c` with globalInt"

917 "_a" "_b" "_c"

918 "_a" "_b" "globalInt"

919

920#if MIN_GHC_API_VERSION(8,6,0)

921 , check "replace hole `_c` with parameterInt"

922 "_a" "_b" "_c"

923 "_a" "_b" "parameterInt"

924#endif

925 ]

926

927addSigActionTests :: TestTree

928addSigActionTests = let

929 header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

930 moduleH = "module Sigs where"

931 before def = T.unlines [header, moduleH, def]

932 after' def sig = T.unlines [header, moduleH, sig, def]

933

934 def >:: sig = testSession (T.unpack def) $ do

935 let originalCode = before def

936 let expectedCode = after' def sig

937 doc <- openDoc' "Sigs.hs" "haskell" originalCode

938 _ <- waitForDiagnostics

939 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

940 let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

941 executeCodeAction chosenAction

942 modifiedCode <- documentContents doc

943 liftIO $ expectedCode @=? modifiedCode

944 in

945 testGroup "add signature"

946 [ "abc = True" >:: "abc :: Bool"

947 , "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"

949 , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

950 , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

951 , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

952 ]

953

954addSigLensesTests :: TestTree

955addSigLensesTests = let

956 missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

957 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

958 moduleH = "module Sigs where"

959 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

960 before withMissing def

961 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

962 after' withMissing def sig

963 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]

964

965 sigSession withMissing def sig = testSession (T.unpack def) $ do

966 let originalCode = before withMissing def

967 let expectedCode = after' withMissing def sig

968 doc <- openDoc' "Sigs.hs" "haskell" originalCode

969 [CodeLens {_command = Just c}] <- getCodeLenses doc

970 executeCommand c

971 modifiedCode <- getDocumentEdit doc

972 liftIO $ expectedCode @=? modifiedCode

973 in

974 testGroup "add signature"

975 [ testGroup "with warnings enabled"

976 [ sigSession True "abc = True" "abc :: Bool"

977 , sigSession True "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"

979 , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

980 , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

981 , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

982 ]

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"

990 ]

991 ]

992

993findDefinitionAndHoverTests :: TestTree

994findDefinitionAndHoverTests = let

995

996 tst (get, check) pos targetRange title = testSession title $ do

997 doc <- openTestDataDoc sourceFilePath

998 found <- get doc pos

999 check found targetRange

1000

1001 checkDefs :: [Location] -> [Expect] -> Session ()

1002 checkDefs defs expectations = traverse_ check expectations where

1003

1004 check (ExpectRange expectedRange) = do

1005 assertNDefinitionsFound 1 defs

1006 assertRangeCorrect (head defs) expectedRange

1007 check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1008 check _ = pure () -- all other expectations not relevant to getDefinition

1009

1010 assertNDefinitionsFound :: Int -> [a] -> Session ()

1011 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1012

1013 assertRangeCorrect Location{_range = foundRange} expectedRange =

1014 liftIO $ expectedRange @=? foundRange

1015

1016 checkHover :: Maybe Hover -> [Expect] -> Session ()

1017 checkHover hover expectations = traverse_ check expectations where

1018

1019 check expected =

1020 case hover of

1021 Nothing -> liftIO $ assertFailure "no hover found"

1022 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

1023 ,_range = rangeInHover } ->

1024 case expected of

1025 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1026 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1027 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

1028 _ -> pure () -- all other expectations not relevant to hover

1029 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

1030

1031 extractLineColFromHoverMsg :: T.Text -> [T.Text]

1032 extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")

1033

1034 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()

1035 checkHoverRange expectedRange rangeInHover msg =

1036 let

1037 lineCol = extractLineColFromHoverMsg msg

1038 -- looks like hovers use 1-based numbering while definitions use 0-based

1039 -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.

1040 adjust Position{_line = l, _character = c} =

1041 Position{_line = l + 1, _character = c + 1}

1042 in

1043 case map (read . T.unpack) lineCol of

1044 [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c

1045 _ -> liftIO $ assertFailure $

1046 "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>

1047 "\n but got: " <> show (msg, rangeInHover)

1048

1049 assertFoundIn :: T.Text -> T.Text -> Assertion

1050 assertFoundIn part whole = assertBool

1051 (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)

1052 (part `T.isInfixOf` whole)

1053

1054 sourceFilePath = T.unpack sourceFileName

1055 sourceFileName = "GotoHover.hs"

1056

1057 mkFindTests tests = testGroup "get"

1058 [ testGroup "definition" $ mapMaybe fst tests

1059 , testGroup "hover" $ mapMaybe snd tests ]

1060

1061 test runDef runHover look expect title =

1062 ( runDef $ tst def look expect title

1063 , runHover $ tst hover look expect title ) where

1064 def = (getDefinitions, checkDefs)

1065 hover = (getHover , checkHover)

1066 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

1067

1068 -- search locations expectations on results

1069 fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

1070 fffL8 = Position 8 4 ;

1071 fffL14 = Position 14 7 ;

1072 aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

1073 dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

1074 dcL12 = Position 12 11 ;

1075 xtcL5 = Position 5 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"]]

1077 vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

1078 opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

1079 opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

1080 aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

1081 b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

1082 xvL20 = Position 20 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"]]

1084 clL25 = Position 25 9

1085 eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

1086 dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

1087 dnbL30 = Position 30 23

1088 lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

1089 lclL33 = Position 33 22

1090 mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

1091 mclL37 = Position 37 1

1092 docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1093 ; constr = [ExpectHoverText ["Monad m =>"]]

1094 eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1095 intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1096 tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1097 intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]

1098 chrL36 = Position 36 25 ; litC = [ExpectHoverText ["'t'"]]

1099 txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgv\""]]

1100 lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]

1101 outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]

1102 innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]

1103 in

1104 mkFindTests

1105 -- def hover look expect

1106 [ test yes yes fffL4 fff "field in record definition"

1107 , 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

1109 , test yes yes aaaL14 aaa "top-level name" -- 120

1110 , test yes yes dcL7 tcDC "data constructor record #247"

1111 , test yes yes dcL12 tcDC "data constructor plain" -- 121

1112 , test yes yes tcL6 tcData "type constructor #248" -- 147

1113 , test broken yes xtcL5 xtc "type constructor external #248,249"

1114 , test broken yes xvL20 xvMsg "value external package #249" -- 120

1115 , test yes yes vvL16 vv "plain parameter" -- 120

1116 , test yes yes aL18 apmp "pattern match name" -- 120

1117 , test yes yes opL16 op "top-level operator" -- 120, 123

1118 , test yes yes opL18 opp "parameter operator" -- 120

1119 , test yes yes b'L19 bp "name in backticks" -- 120

1120 , test yes yes clL23 cls "class in instance declaration #250"

1121 , test yes yes clL25 cls "class in signature #250" -- 147

1122 , test broken yes eclL15 ecls "external class in signature #249,250"

1123 , test yes yes dnbL29 dnb "do-notation bind" -- 137

1124 , test yes yes dnbL30 dnb "do-notation lookup"

1125 , test yes yes lcbL33 lcb "listcomp bind" -- 137

1126 , test yes yes lclL33 lcb "listcomp lookup"

1127 , test yes yes mclL36 mcl "top-level fn 1st clause"

1128 , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1129 , test no broken docL41 doc "documentation #7"

1130 , test no broken eitL40 kindE "kind of Either #273"

1131 , test no broken intL40 kindI "kind of Int #273"

1132 , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1133 , test no broken intL41 litI "literal Int in hover info #274"

1134 , test no broken chrL36 litC "literal Char in hover info #274"

1135 , test no broken txtL8 litT "literal Text in hover info #274"

1136 , test no broken lstL43 litL "literal List in hover info #274"

1137 , test no broken docL41 constr "type constraint in hover info #283"

1138 , test broken broken outL45 outSig "top-level signature #310"

1139 , test broken broken innL48 innSig "inner signature #310"

1140 ]

1141 where yes, broken :: (TestTree -> Maybe TestTree)

1142 yes = Just -- test should run and pass

1143 broken = Just . (`xfail` "known broken")

1144 no = const Nothing -- don't run this test at all

1145

1146pluginTests :: TestTree

1147pluginTests = testSessionWait "plugins" $ do

1148 let content =

1149 T.unlines

1150 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

1151 , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"

1152 , "module Testing where"

1153 , "import Data.Proxy"

1154 , "import GHC.TypeLits"

1155 -- This function fails without plugins being initialized.

1156 , "f :: forall n. KnownNat n => Proxy n -> Integer"

1157 , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"

1158 , "foo :: Int -> Int -> Int"

1159 , "foo a b = a + c"

1160 ]

1161 _ <- openDoc' "Testing.hs" "haskell" content

1162 expectDiagnostics

1163 [ ( "Testing.hs",

1164 [(DsError, (8, 14), "Variable not in scope: c")]

1165 )

1166 ]

1167

1168cppTests :: TestTree

1169cppTests =

1170 testCase "cpp" $ do

1171 let content =

1172 T.unlines

1173 [ "{-# LANGUAGE CPP #-}",

1174 "module Testing where",

1175 "#ifdef FOO",

1176 "foo = 42"

1177 ]

1178 -- 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

1180 -- of them.

1181 (run $ expectError content (2, -1))

1182 `catch` ( \e -> do

1183 let _ = e :: HUnitFailure

1184 run $ expectError content (2, 1)

1185 )

1186 where

1187 expectError :: T.Text -> Cursor -> Session ()

1188 expectError content cursor = do

1189 _ <- openDoc' "Testing.hs" "haskell" content

1190 expectDiagnostics

1191 [ ( "Testing.hs",

1192 [(DsError, cursor, "error: unterminated")]

1193 )

1194 ]

1195 expectNoMoreDiagnostics 0.5

1196

1197preprocessorTests :: TestTree

1198preprocessorTests = testSessionWait "preprocessor" $ do

1199 let content =

1200 T.unlines

1201 [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"

1202 , "module Testing where"

1203 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1204 ]

1205 _ <- openDoc' "Testing.hs" "haskell" content

1206 expectDiagnostics

1207 [ ( "Testing.hs",

1208 [(DsError, (2, 8), "Variable not in scope: z")]

1209 )

1210 ]

1211

1212thTests :: TestTree

1213thTests =

1214 testGroup

1215 "TemplateHaskell"

1216 [ -- Test for https://github.com/digital-asset/ghcide/pull/212

1217 testSessionWait "load" $ do

1218 let sourceA =

1219 T.unlines

1220 [ "{-# LANGUAGE PackageImports #-}",

1221 "{-# LANGUAGE TemplateHaskell #-}",

1222 "module A where",

1223 "import \"template-haskell\" Language.Haskell.TH",

1224 "a :: Integer",

1225 "a = $(litE $ IntegerL 3)"

1226 ]

1227 sourceB =

1228 T.unlines

1229 [ "{-# LANGUAGE PackageImports #-}",

1230 "{-# LANGUAGE TemplateHaskell #-}",

1231 "module B where",

1232 "import A",

1233 "import \"template-haskell\" Language.Haskell.TH",

1234 "b :: Integer",

1235 "b = $(litE $ IntegerL $ a) + n"

1236 ]

1237 _ <- openDoc' "A.hs" "haskell" sourceA

1238 _ <- openDoc' "B.hs" "haskell" sourceB

1239 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1240 ]

1241

1242completionTests :: TestTree

1243completionTests

1244 = testGroup "completion"

1245 [ testSessionWait "variable" $ do

1246 let source = T.unlines ["module A where", "f = hea"]

1247 docId <- openDoc' "A.hs" "haskell" source

1248 compls <- getCompletions docId (Position 1 7)

1249 liftIO $ map dropDocs compls @?=

1250 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1251 let [CompletionItem { _documentation = headDocs}] = compls

1252 checkDocText "head" headDocs [ "Defined in 'Prelude'"

1253#if MIN_GHC_API_VERSION(8,6,0)

1254 , "Extract the first element of a list"

1255#endif

1256 ]

1257 , testSessionWait "constructor" $ do

1258 let source = T.unlines ["module A where", "f = Tru"]

1259 docId <- openDoc' "A.hs" "haskell" source

1260 compls <- getCompletions docId (Position 1 7)

1261 liftIO $ map dropDocs compls @?=

1262 [ complItem "True" (Just CiConstructor) (Just "Bool")

1263#if MIN_GHC_API_VERSION(8,6,0)

1264 , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")

1265#else

1266 , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")

1267#endif

1268 ]

1269 , testSessionWait "type" $ do

1270 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1271 docId <- openDoc' "A.hs" "haskell" source

1272 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"]]

1274 compls <- getCompletions docId (Position 2 7)

1275 liftIO $ map dropDocs compls @?=

1276 [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")

1277 , complItem "Bool" (Just CiStruct) (Just "*") ]

1278 let [ CompletionItem { _documentation = boundedDocs},

1279 CompletionItem { _documentation = boolDocs } ] = compls

1280 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"

1281#if MIN_GHC_API_VERSION(8,6,0)

1282 , "name the upper and lower limits"

1283#endif

1284 ]

1285 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1286 , testSessionWait "qualified" $ do

1287 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1288 docId <- openDoc' "A.hs" "haskell" source

1289 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"]]

1291 compls <- getCompletions docId (Position 2 15)

1292 liftIO $ map dropDocs compls @?=

1293 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1294 let [CompletionItem { _documentation = headDocs}] = compls

1295 checkDocText "head" headDocs [ "Defined in 'Prelude'"

1296#if MIN_GHC_API_VERSION(8,6,0)

1297 , "Extract the first element of a list"

1298#endif

1299 ]

1300 ]

1301 where

1302 dropDocs :: CompletionItem -> CompletionItem

1303 dropDocs ci = ci { _documentation = Nothing }

1304 complItem label kind ty = CompletionItem

1305 { _label = label

1306 , _kind = kind

1307 , _detail = (":: " <>) <$> ty

1308 , _documentation = Nothing

1309 , _deprecated = Nothing

1310 , _preselect = Nothing

1311 , _sortText = Nothing

1312 , _filterText = Nothing

1313 , _insertText = Nothing

1314 , _insertTextFormat = Just PlainText

1315 , _textEdit = Nothing

1316 , _additionalTextEdits = Nothing

1317 , _commitCharacters = Nothing

1318 , _command = Nothing

1319 , _xdata = Nothing

1320 }

1321 getDocText (CompletionDocString s) = s

1322 getDocText (CompletionDocMarkup (MarkupContent _ s)) = s

1323 checkDocText thing Nothing _

1324 = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"

1325 checkDocText thing (Just doc) items

1326 = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $

1327 all (`T.isInfixOf` getDocText doc) items

1328

1329outlineTests :: TestTree

1330outlineTests = testGroup

1331 "outline"

1332 [ testSessionWait "type class" $ do

1333 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1334 docId <- openDoc' "A.hs" "haskell" source

1335 symbols <- getDocumentSymbols docId

1336 liftIO $ symbols @?= Left

1337 [ moduleSymbol

1338 "A"

1339 (R 0 7 0 8)

1340 [ classSymbol "A a"

1341 (R 1 0 1 30)

1342 [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]

1343 ]

1344 ]

1345 , testSessionWait "type class instance " $ do

1346 let source = T.unlines ["class A a where", "instance A () where"]

1347 docId <- openDoc' "A.hs" "haskell" source

1348 symbols <- getDocumentSymbols docId

1349 liftIO $ symbols @?= Left

1350 [ classSymbol "A a" (R 0 0 0 15) []

1351 , docSymbol "A ()" SkInterface (R 1 0 1 19)

1352 ]

1353 , testSessionWait "type family" $ do

1354 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1355 docId <- openDoc' "A.hs" "haskell" source

1356 symbols <- getDocumentSymbols docId

1357 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1358 , testSessionWait "type family instance " $ do

1359 let source = T.unlines

1360 [ "{-# language TypeFamilies #-}"

1361 , "type family A a"

1362 , "type instance A () = ()"

1363 ]

1364 docId <- openDoc' "A.hs" "haskell" source

1365 symbols <- getDocumentSymbols docId

1366 liftIO $ symbols @?= Left

1367 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1368 , docSymbol "A ()" SkInterface (R 2 0 2 23)

1369 ]

1370 , testSessionWait "data family" $ do

1371 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1372 docId <- openDoc' "A.hs" "haskell" source

1373 symbols <- getDocumentSymbols docId

1374 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1375 , testSessionWait "data family instance " $ do

1376 let source = T.unlines

1377 [ "{-# language TypeFamilies #-}"

1378 , "data family A a"

1379 , "data instance A () = A ()"

1380 ]

1381 docId <- openDoc' "A.hs" "haskell" source

1382 symbols <- getDocumentSymbols docId

1383 liftIO $ symbols @?= Left

1384 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1385 , docSymbol "A ()" SkInterface (R 2 0 2 25)

1386 ]

1387 , testSessionWait "constant" $ do

1388 let source = T.unlines ["a = ()"]

1389 docId <- openDoc' "A.hs" "haskell" source

1390 symbols <- getDocumentSymbols docId

1391 liftIO $ symbols @?= Left

1392 [docSymbol "a" SkFunction (R 0 0 0 6)]

1393 , testSessionWait "pattern" $ do

1394 let source = T.unlines ["Just foo = Just 21"]

1395 docId <- openDoc' "A.hs" "haskell" source

1396 symbols <- getDocumentSymbols docId

1397 liftIO $ symbols @?= Left

1398 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1399 , testSessionWait "pattern with type signature" $ do

1400 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1401 docId <- openDoc' "A.hs" "haskell" source

1402 symbols <- getDocumentSymbols docId

1403 liftIO $ symbols @?= Left

1404 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1405 , testSessionWait "function" $ do

1406 let source = T.unlines ["a x = ()"]

1407 docId <- openDoc' "A.hs" "haskell" source

1408 symbols <- getDocumentSymbols docId

1409 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1410 , testSessionWait "type synonym" $ do

1411 let source = T.unlines ["type A = Bool"]

1412 docId <- openDoc' "A.hs" "haskell" source

1413 symbols <- getDocumentSymbols docId

1414 liftIO $ symbols @?= Left

1415 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1416 , testSessionWait "datatype" $ do

1417 let source = T.unlines ["data A = C"]

1418 docId <- openDoc' "A.hs" "haskell" source

1419 symbols <- getDocumentSymbols docId

1420 liftIO $ symbols @?= Left

1421 [ docSymbolWithChildren "A"

1422 SkStruct

1423 (R 0 0 0 10)

1424 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1425 ]

1426 , testSessionWait "import" $ do

1427 let source = T.unlines ["import Data.Maybe"]

1428 docId <- openDoc' "A.hs" "haskell" source

1429 symbols <- getDocumentSymbols docId

1430 liftIO $ symbols @?= Left

1431 [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]

1432 , testSessionWait "foreign import" $ do

1433 let source = T.unlines

1434 [ "{-# language ForeignFunctionInterface #-}"

1435 , "foreign import ccall \"a\" a :: Int"

1436 ]

1437 docId <- openDoc' "A.hs" "haskell" source

1438 symbols <- getDocumentSymbols docId

1439 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1440 , testSessionWait "foreign export" $ do

1441 let source = T.unlines

1442 [ "{-# language ForeignFunctionInterface #-}"

1443 , "foreign export ccall odd :: Int -> Bool"

1444 ]

1445 docId <- openDoc' "A.hs" "haskell" source

1446 symbols <- getDocumentSymbols docId

1447 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1448 ]

1449 where

1450 docSymbol name kind loc =

1451 DocumentSymbol name Nothing kind Nothing loc loc Nothing

1452 docSymbol' name kind loc selectionLoc =

1453 DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing

1454 docSymbolD name detail kind loc =

1455 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1456 docSymbolWithChildren name kind loc cc =

1457 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1458 moduleSymbol name loc cc = DocumentSymbol name

1459 Nothing

1460 SkFile

1461 Nothing

1462 (R 0 0 maxBound 0)

1463 loc

1464 (Just $ List cc)

1465 classSymbol name loc cc = DocumentSymbol name

1466 (Just "class")

1467 SkClass

1468 Nothing

1469 loc

1470 loc

1471 (Just $ List cc)

1472

1473pattern R :: Int -> Int -> Int -> Int -> Range

1474pattern R x y x' y' = Range (Position x y) (Position x' y')

1475

1476xfail :: TestTree -> String -> TestTree

1477xfail = flip expectFailBecause

1478

1479data Expect

1480 = ExpectRange Range -- Both gotoDef and hover should report this range

1481-- | ExpectDefRange Range -- Only gotoDef should report this range

1482 | ExpectHoverRange Range -- Only hover should report this range

1483 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

1484 | ExpectExternFail -- definition lookup in other file expected to fail

1485-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1486

1487mkR :: Int -> Int -> Int -> Int -> Expect

1488mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

1489----------------------------------------------------------------------

1490-- Utils

1491

1492

1493testSession :: String -> Session () -> TestTree

1494testSession name = testCase name . run

1495

1496testSessionWait :: String -> Session () -> TestTree

1497testSessionWait name = testSession name .

1498 -- Check that any diagnostics produced were already consumed by the test case.

1499 --

1500 -- If in future we add test cases where we don't care about checking the diagnostics,

1501 -- this could move elsewhere.

1502 --

1503 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

1504 ( >> expectNoMoreDiagnostics 0.5)

1505

1506pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

1507pickActionWithTitle title actions = head

1508 [ action

1509 | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

1510 , title == actionTitle ]

1511

1512mkRange :: Int -> Int -> Int -> Int -> Range

1513mkRange a b c d = Range (Position a b) (Position c d)

1514

1515run :: Session a -> IO a

1516run s = withTempDir $ \dir -> do

1517 ghcideExe <- locateGhcideExecutable

1518

1519 -- 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

1521 createDirectoryIfMissing True $ dir ++ "/Data"

1522

1523 let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

1524 -- HIE calls getXgdDirectory which assumes that HOME is set.

1525 -- Only sets HOME if it wasn't already set.

1526 setEnv "HOME" "/homeless-shelter" False

1527 runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s

1528 where

1529 conf = defaultConfig

1530 -- If you uncomment this you can see all logging

1531 -- which can be quite useful for debugging.

1532 -- { logStdErr = True, logColor = False }

1533 -- If you really want to, you can also see all messages

1534 -- { logMessages = True, logColor = False }

1535

1536openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

1537openTestDataDoc path = do

1538 source <- liftIO $ readFileUtf8 $ "test/data" </> path

1539 openDoc' path "haskell" source

1540

1541unitTests :: TestTree

1542unitTests = do

1543 testGroup "Unit"

1544 [ testCase "empty file path" $

1545 uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""

1546 ]