@@ -1,158 +1,39 @@
11-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4−{-# LANGUAGE AllowAmbiguousTypes #-}
54{-# LANGUAGE DuplicateRecordFields #-}
6−{-# LANGUAGE PatternSynonyms #-}
7−{-# LANGUAGE CPP #-}
8−#include "ghc-api-version.h"
95
106module Main (main) where
117
12−import Control.Applicative.Combinators
13−import Control.Exception (bracket, catch)
14−import qualified Control.Lens as Lens
15−import Control.Monad
16−import Control.Monad.IO.Class (liftIO)
17−import Data.Aeson (FromJSON, Value)
18−import Data.Foldable
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)
23−import Development.IDE.GHC.Util
8+import Control.Monad (void)
249import qualified Data.Text as T
25−import Data.Typeable
26−import Development.IDE.Spans.Common
2710import Development.IDE.Test
2811import Development.IDE.Test.Runfiles
29−import Development.IDE.Types.Location
30−import Development.Shake (getDirectoryFilesIO)
3112import Language.Haskell.LSP.Test
32−import Language.Haskell.LSP.Messages
3313import Language.Haskell.LSP.Types
3414import 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)
37−import Network.URI
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
39−import System.FilePath
15+import System.Environment.Blank (setEnv)
4016import System.IO.Extra
41−import System.Directory
42−import Test.QuickCheck
43−import Test.QuickCheck.Instances ()
4417import Test.Tasty
45−import Test.Tasty.ExpectedFailure
46−import Test.Tasty.Ingredients.Rerun
4718import Test.Tasty.HUnit
48−import Test.Tasty.QuickCheck
49−import Data.Maybe
5019
51−main :: IO ()
52−main = do
53− -- We mess with env vars so run single-threaded.
54− setEnv "TASTY_NUM_THREADS" "1" True
55− defaultMainWithRerun $ testGroup "HIE"
56− [ testSession "open close" $ do
57− doc <- createDoc "Testing.hs" "haskell" ""
58− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
59− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
60− closeDoc doc
61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
62− , initializeResponseTests
63− , completionTests
64− , cppTests
65− , diagnosticTests
66− , codeActionTests
67− , codeLensesTests
68− , outlineTests
69− , findDefinitionAndHoverTests
70− , pluginTests
71− , preprocessorTests
72− , thTests
73− , safeTests
74− , unitTests
75− , haddockTests
76− , positionMappingTests
77− , watchedFilesTests
78− , cradleTests
79− , dependentFileTest
80− ]
81−
82−initializeResponseTests :: TestTree
83−initializeResponseTests = withResource acquire release tests where
84−
85− -- these tests document and monitor the evolution of the
86− -- capabilities announced by the server in the initialize
87− -- response. Currently the server advertises almost no capabilities
88− -- at all, in some cases failing to announce capabilities that it
89− -- actually does provide! Hopefully this will change ...
90− tests :: IO InitializeResponse -> TestTree
91− tests getInitializeResponse =
92− testGroup "initialize response capabilities"
93− [ chk " text doc sync" _textDocumentSync tds
94− , chk " hover" _hoverProvider (Just True)
95− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
96− , chk "NO signature help" _signatureHelpProvider Nothing
97− , chk " goto definition" _definitionProvider (Just True)
98− , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
99− , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
100− , chk "NO find references" _referencesProvider Nothing
101− , chk "NO doc highlight" _documentHighlightProvider Nothing
102− , chk " doc symbol" _documentSymbolProvider (Just True)
103− , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
104− , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
105− , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
106− , chk "NO doc formatting" _documentFormattingProvider Nothing
107− , chk "NO doc range formatting"
108− _documentRangeFormattingProvider Nothing
109− , chk "NO doc formatting on typing"
110− _documentOnTypeFormattingProvider Nothing
111− , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False)
112− , chk "NO doc link" _documentLinkProvider Nothing
113− , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114− , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116− , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
117− , chk "NO experimental" _experimental Nothing
118− ] where
119−
120− tds = Just (TDSOptions (TextDocumentSyncOptions
121− { _openClose = Just True
122− , _change = Just TdSyncIncremental
123− , _willSave = Nothing
124− , _willSaveWaitUntil = Nothing
125− , _save = Just (SaveOptions {_includeText = Nothing})}))
126−
127− chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
128− chk title getActual expected =
129− testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
13020
131− che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132− che title getActual _expected = testCase title doTest
133− where
134− doTest = do
135− ir <- getInitializeResponse
136− let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137− True @=? T.isSuffixOf "typesignature.add" command
138−
139−
140− innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
142− innerCaps _ = error "this test only expects inner capabilities"
143−
144− acquire :: IO InitializeResponse
145− acquire = run initializeResponse
146−
147− release :: InitializeResponse -> IO ()
148− release = const $ pure ()
21+main :: IO ()
22+main = defaultMain $ testGroup "HIE"
23+ [ testSession "open close" $ do
24+ doc <- openDoc' "Testing.hs" "haskell" ""
25+ void (message :: Session ProgressStartNotification)
26+ closeDoc doc
27+ void (message :: Session ProgressDoneNotification)
28+ , diagnosticTests
29+ ]
14930
15031
15132diagnosticTests :: TestTree
15233diagnosticTests = testGroup "diagnostics"
153− [ testSessionWait "fix syntax error" $ do
34+ [ testSession "fix syntax error" $ do
15435 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
36+ doc <- openDoc' "Testing.hs" "haskell" content
15637 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
15738 let change = TextDocumentContentChangeEvent
15839 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -161,11 +42,10 @@ diagnosticTests = testGroup "diagnostics"
16142 }
16243 changeDoc doc [change]
16344 expectDiagnostics [("Testing.hs", [])]
164− , testSessionWait "introduce syntax error" $ do
45+ , testSession "introduce syntax error" $ do
16546 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
47+ doc <- openDoc' "Testing.hs" "haskell" content
48+ void (message :: Session ProgressStartNotification)
16949 let change = TextDocumentContentChangeEvent
17050 { _range = Just (Range (Position 0 15) (Position 0 18))
17151 , _rangeLength = Nothing
@@ -173,7 +53,7 @@ diagnosticTests = testGroup "diagnostics"
17353 }
17454 changeDoc doc [change]
17555 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
176− , testSessionWait "variable not in scope" $ do
56+ , testSession "variable not in scope" $ do
17757 let content = T.unlines
17858 [ "module Testing where"
17959 , "foo :: Int -> Int -> Int"
@@ -181,7 +61,7 @@ diagnosticTests = testGroup "diagnostics"
18161 , "bar :: Int -> Int -> Int"
18262 , "bar a b = cd + b"
18363 ]
184− _ <- createDoc "Testing.hs" "haskell" content
64+ _ <- openDoc' "Testing.hs" "haskell" content
18565 expectDiagnostics
18666 [ ( "Testing.hs"
18767 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -189,63 +69,26 @@ diagnosticTests = testGroup "diagnostics"
18969 ]
19070 )
19171 ]
192− , testSessionWait "type error" $ do
72+ , testSession "type error" $ do
19373 let content = T.unlines
19474 [ "module Testing where"
19575 , "foo :: Int -> String -> Int"
19676 , "foo a b = a + b"
19777 ]
198− _ <- createDoc "Testing.hs" "haskell" content
78+ _ <- openDoc' "Testing.hs" "haskell" content
19979 expectDiagnostics
20080 [ ( "Testing.hs"
20181 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
20282 )
20383 ]
204− , testSessionWait "typed hole" $ do
205− let content = T.unlines
206− [ "module Testing where"
207− , "foo :: Int -> String"
208− , "foo a = _ a"
209− ]
210− _ <- createDoc "Testing.hs" "haskell" content
211− expectDiagnostics
212− [ ( "Testing.hs"
213− , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
214− )
215− ]
216−
217− , testGroup "deferral" $
218− let sourceA a = T.unlines
219− [ "module A where"
220− , "a :: Int"
221− , "a = " <> a]
222− sourceB = T.unlines
223− [ "module B where"
224− , "import A"
225− , "b :: Float"
226− , "b = True"]
227− bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"
228− expectedDs aMessage =
229− [ ("A.hs", [(DsError, (2,4), aMessage)])
230− , ("B.hs", [(DsError, (3,4), bMessage)])]
231− deferralTest title binding msg = testSessionWait title $ do
232− _ <- createDoc "A.hs" "haskell" $ sourceA binding
233− _ <- createDoc "B.hs" "haskell" sourceB
234− expectDiagnostics $ expectedDs msg
235− in
236− [ deferralTest "type error" "True" "Couldn't match expected type"
237− , deferralTest "typed hole" "_" "Found hole"
238− , deferralTest "out of scope var" "unbound" "Variable not in scope"
239− ]
240−
241− , testSessionWait "remove required module" $ do
84+ , testSession "remove required module" $ do
24285 let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
86+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
24487 let contentB = T.unlines
24588 [ "module ModuleB where"
24689 , "import ModuleA"
24790 ]
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
91+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
24992 let change = TextDocumentContentChangeEvent
25093 { _range = Just (Range (Position 0 0) (Position 0 20))
25194 , _rangeLength = Nothing
@@ -253,27 +96,17 @@ diagnosticTests = testGroup "diagnostics"
25396 }
25497 changeDoc docA [change]
25598 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
256− , testSessionWait "add missing module" $ do
99+ , testSession "add missing module" $ do
257100 let contentB = T.unlines
258101 [ "module ModuleB where"
259102 , "import ModuleA"
260103 ]
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
104+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
262105 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263106 let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
107+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
265108 expectDiagnostics [("ModuleB.hs", [])]
266− , testSessionWait "add missing module (non workspace)" $ do
267− let contentB = T.unlines
268− [ "module ModuleB where"
269− , "import ModuleA"
270− ]
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", [])]
276− , testSessionWait "cyclic module dependency" $ do
109+ , testSession "cyclic module dependency" $ do
277110 let contentA = T.unlines
278111 [ "module ModuleA where"
279112 , "import ModuleB"
@@ -282,8 +115,8 @@ diagnosticTests = testGroup "diagnostics"
282115 [ "module ModuleB where"
283116 , "import ModuleA"
284117 ]
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
118+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
119+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
287120 expectDiagnostics
288121 [ ( "ModuleA.hs"
289122 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -292,7 +125,7 @@ diagnosticTests = testGroup "diagnostics"
292125 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
293126 )
294127 ]
295− , testSessionWait "cyclic module dependency with hs-boot" $ do
128+ , testSession "cyclic module dependency with hs-boot" $ do
296129 let contentA = T.unlines
297130 [ "module ModuleA where"
298131 , "import {-# SOURCE #-} ModuleB"
@@ -304,11 +137,11 @@ diagnosticTests = testGroup "diagnostics"
304137 let contentBboot = T.unlines
305138 [ "module ModuleB where"
306139 ]
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
140+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
141+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
142+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
310143 expectDiagnostics []
311− , testSessionWait "correct reference used with hs-boot" $ do
144+ , testSession "correct reference used with hs-boot" $ do
312145 let contentB = T.unlines
313146 [ "module ModuleB where"
314147 , "import {-# SOURCE #-} ModuleA"
@@ -328,1866 +161,26 @@ diagnosticTests = testGroup "diagnostics"
328161 -- resolved to the hs-boot file
329162 , "y = x"
330163 ]
331− _ <- createDoc "ModuleB.hs" "haskell" contentB
332− _ <- createDoc "ModuleA.hs" "haskell" contentA
333− _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
334− _ <- createDoc "ModuleC.hs" "haskell" contentC
164+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
165+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
166+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
167+ _ <- openDoc' "ModuleC.hs" "haskell" contentC
335168 expectDiagnostics []
336− , testSessionWait "redundant import" $ do
169+ , testSession "redundant import" $ do
337170 let contentA = T.unlines ["module ModuleA where"]
338171 let contentB = T.unlines
339172 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
340173 , "module ModuleB where"
341174 , "import ModuleA"
342175 ]
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
176+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
177+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
345178 expectDiagnostics
346179 [ ( "ModuleB.hs"
347180 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
348181 )
349182 ]
350− , testSessionWait "package imports" $ do
351− let thisDataListContent = T.unlines
352− [ "module Data.List where"
353− , "x :: Integer"
354− , "x = 123"
355− ]
356− let mainContent = T.unlines
357− [ "{-# LANGUAGE PackageImports #-}"
358− , "module Main where"
359− , "import qualified \"this\" Data.List as ThisList"
360− , "import qualified \"base\" Data.List as BaseList"
361− , "useThis = ThisList.x"
362− , "useBase = BaseList.map"
363− , "wrong1 = ThisList.map"
364− , "wrong2 = BaseList.x"
365− ]
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
368− expectDiagnostics
369− [ ( "Main.hs"
370− , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
371− ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
372− ]
373− )
374− ]
375− , testSessionWait "unqualified warnings" $ do
376− let fooContent = T.unlines
377− [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
378− , "module Foo where"
379− , "foo :: Ord a => a -> Int"
380− , "foo a = 1"
381− ]
382− _ <- createDoc "Foo.hs" "haskell" fooContent
383− expectDiagnostics
384− [ ( "Foo.hs"
385− -- The test is to make sure that warnings contain unqualified names
386− -- where appropriate. The warning should use an unqualified name 'Ord', not
387− -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
388− -- test this is fairly arbitrary.
389− , [(DsWarning, (2, 0), "Redundant constraint: Ord a")
390− ]
391− )
392− ]
393− , testSessionWait "lower-case drive" $ do
394− let aContent = T.unlines
395− [ "module A.A where"
396− , "import A.B ()"
397− ]
398− bContent = T.unlines
399− [ "{-# OPTIONS_GHC -Wall #-}"
400− , "module A.B where"
401− , "import Data.List"
402− ]
403− uriB <- getDocUri "A/B.hs"
404− Just pathB <- pure $ uriToFilePath uriB
405− uriB <- pure $
406− let (drive, suffix) = splitDrive pathB
407− in filePathToUri (joinDrive (lower drive) suffix)
408− liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409− liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410− uriA <- getDocUri "A/A.hs"
411− Just pathA <- pure $ uriToFilePath uriA
412− uriA <- pure $
413− let (drive, suffix) = splitDrive pathA
414− in filePathToUri (joinDrive (lower drive) suffix)
415− let itemA = TextDocumentItem uriA "haskell" 0 aContent
416− let a = TextDocumentIdentifier uriA
417− sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418− diagsNot <- skipManyTill anyMessage diagnostic
419− let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420− -- Check that if we put a lower-case drive in for A.A
421− -- the diagnostics for A.B will also be lower-case.
422− liftIO $ fileUri @?= uriB
423− let msg = _message (head (toList diags) :: Diagnostic)
424− liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425− assertFailure ("Expected redundant import but got " <> T.unpack msg)
426− closeDoc a
427− , testSessionWait "haddock parse error" $ do
428− let fooContent = T.unlines
429− [ "module Foo where"
430− , "foo :: Int"
431− , "foo = 1 {-|-}"
432− ]
433− _ <- createDoc "Foo.hs" "haskell" fooContent
434− expectDiagnostics
435− [ ( "Foo.hs"
436− , [(DsError, (2, 8), "Parse error on input")
437− ]
438− )
439− ]
440− , testSessionWait "strip file path" $ do
441− let
442− name = "Testing"
443− content = T.unlines
444− [ "module " <> name <> " where"
445− , "value :: Maybe ()"
446− , "value = [()]"
447− ]
448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449− notification <- skipManyTill anyMessage diagnostic
450− let
451− offenders =
452− Lsp.params .
453− Lsp.diagnostics .
454− Lens.folded .
455− Lsp.message .
456− Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457− failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458− Lens.mapMOf_ offenders failure notification
459− ]
460−
461−codeActionTests :: TestTree
462−codeActionTests = testGroup "code actions"
463− [ renameActionTests
464− , typeWildCardActionTests
465− , removeImportTests
466− , extendImportTests
467− , suggestImportTests
468− , addExtensionTests
469− , fixConstructorImportTests
470− , importRenameActionTests
471− , fillTypedHoleTests
472− , addSigActionTests
473− , insertNewDefinitionTests
474− ]
475−
476−codeLensesTests :: TestTree
477−codeLensesTests = testGroup "code lenses"
478− [ addSigLensesTests
479− ]
480−
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
487−
488− -- Expect 4 subscriptions (A does not get any because it's VFS):
489− -- - /path-to-workspace/WatchedFilesMissingModule.hs
490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493− liftIO $ length watchedFileRegs @?= 4
494−
495− , testSession' "non workspace file" $ \sessionDir -> do
496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
499−
500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501− -- - /path-to-workspace/WatchedFilesMissingModule.hs
502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503− liftIO $ length watchedFileRegs @?= 2
504−
505− -- TODO add a test for didChangeWorkspaceFolder
506− ]
507−
508−renameActionTests :: TestTree
509−renameActionTests = testGroup "rename actions"
510− [ testSession "change to local variable name" $ do
511− let content = T.unlines
512− [ "module Testing where"
513− , "foo :: Int -> Int"
514− , "foo argName = argNme"
515− ]
516− doc <- createDoc "Testing.hs" "haskell" content
517− _ <- waitForDiagnostics
518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
519− executeCodeAction action
520− contentAfterAction <- documentContents doc
521− let expectedContentAfterAction = T.unlines
522− [ "module Testing where"
523− , "foo :: Int -> Int"
524− , "foo argName = argName"
525− ]
526− liftIO $ expectedContentAfterAction @=? contentAfterAction
527− , testSession "change to name of imported function" $ do
528− let content = T.unlines
529− [ "module Testing where"
530− , "import Data.Maybe (maybeToList)"
531− , "foo :: Maybe a -> [a]"
532− , "foo = maybToList"
533− ]
534− doc <- createDoc "Testing.hs" "haskell" content
535− _ <- waitForDiagnostics
536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
537− executeCodeAction action
538− contentAfterAction <- documentContents doc
539− let expectedContentAfterAction = T.unlines
540− [ "module Testing where"
541− , "import Data.Maybe (maybeToList)"
542− , "foo :: Maybe a -> [a]"
543− , "foo = maybeToList"
544− ]
545− liftIO $ expectedContentAfterAction @=? contentAfterAction
546− , testSession "suggest multiple local variable names" $ do
547− let content = T.unlines
548− [ "module Testing where"
549− , "foo :: Char -> Char -> Char -> Char"
550− , "foo argument1 argument2 argument3 = argumentX"
551− ]
552− doc <- createDoc "Testing.hs" "haskell" content
553− _ <- waitForDiagnostics
554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
556− return()
557− , testSession "change infix function" $ do
558− let content = T.unlines
559− [ "module Testing where"
560− , "monus :: Int -> Int"
561− , "monus x y = max 0 (x - y)"
562− , "foo x y = x `monnus` y"
563− ]
564− doc <- createDoc "Testing.hs" "haskell" content
565− _ <- waitForDiagnostics
566− actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567− [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
568− executeCodeAction fixTypo
569− contentAfterAction <- documentContents doc
570− let expectedContentAfterAction = T.unlines
571− [ "module Testing where"
572− , "monus :: Int -> Int"
573− , "monus x y = max 0 (x - y)"
574− , "foo x y = x `monus` y"
575− ]
576− liftIO $ expectedContentAfterAction @=? contentAfterAction
577− ]
578−
579−typeWildCardActionTests :: TestTree
580−typeWildCardActionTests = testGroup "type wildcard actions"
581− [ testSession "global signature" $ do
582− let content = T.unlines
583− [ "module Testing where"
584− , "func :: _"
585− , "func x = x"
586− ]
587− doc <- createDoc "Testing.hs" "haskell" content
588− _ <- waitForDiagnostics
589− actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
591− , "Use type signature" `T.isInfixOf` actionTitle
592− ]
593− executeCodeAction addSignature
594− contentAfterAction <- documentContents doc
595− let expectedContentAfterAction = T.unlines
596− [ "module Testing where"
597− , "func :: (p -> p)"
598− , "func x = x"
599− ]
600− liftIO $ expectedContentAfterAction @=? contentAfterAction
601− , testSession "multi-line message" $ do
602− let content = T.unlines
603− [ "module Testing where"
604− , "func :: _"
605− , "func x y = x + y"
606− ]
607− doc <- createDoc "Testing.hs" "haskell" content
608− _ <- waitForDiagnostics
609− actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
611− , "Use type signature" `T.isInfixOf` actionTitle
612− ]
613− executeCodeAction addSignature
614− contentAfterAction <- documentContents doc
615− let expectedContentAfterAction = T.unlines
616− [ "module Testing where"
617− , "func :: (Integer -> Integer -> Integer)"
618− , "func x y = x + y"
619− ]
620− liftIO $ expectedContentAfterAction @=? contentAfterAction
621− , testSession "local signature" $ do
622− let content = T.unlines
623− [ "module Testing where"
624− , "func :: Int -> Int"
625− , "func x ="
626− , " let y :: _"
627− , " y = x * 2"
628− , " in y"
629− ]
630− doc <- createDoc "Testing.hs" "haskell" content
631− _ <- waitForDiagnostics
632− actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
634− , "Use type signature" `T.isInfixOf` actionTitle
635− ]
636− executeCodeAction addSignature
637− contentAfterAction <- documentContents doc
638− let expectedContentAfterAction = T.unlines
639− [ "module Testing where"
640− , "func :: Int -> Int"
641− , "func x ="
642− , " let y :: (Int)"
643− , " y = x * 2"
644− , " in y"
645− ]
646− liftIO $ expectedContentAfterAction @=? contentAfterAction
647− ]
648−
649−removeImportTests :: TestTree
650−removeImportTests = testGroup "remove import actions"
651− [ testSession "redundant" $ do
652− let contentA = T.unlines
653− [ "module ModuleA where"
654− ]
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
656− let contentB = T.unlines
657− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658− , "module ModuleB where"
659− , "import ModuleA"
660− , "stuffB :: Integer"
661− , "stuffB = 123"
662− ]
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
664− _ <- waitForDiagnostics
665− [CACodeAction action@CodeAction { _title = actionTitle }]
666− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
667− liftIO $ "Remove import" @=? actionTitle
668− executeCodeAction action
669− contentAfterAction <- documentContents docB
670− let expectedContentAfterAction = T.unlines
671− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
672− , "module ModuleB where"
673− , "stuffB :: Integer"
674− , "stuffB = 123"
675− ]
676− liftIO $ expectedContentAfterAction @=? contentAfterAction
677− , testSession "qualified redundant" $ do
678− let contentA = T.unlines
679− [ "module ModuleA where"
680− ]
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
682− let contentB = T.unlines
683− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684− , "module ModuleB where"
685− , "import qualified ModuleA"
686− , "stuffB :: Integer"
687− , "stuffB = 123"
688− ]
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
690− _ <- waitForDiagnostics
691− [CACodeAction action@CodeAction { _title = actionTitle }]
692− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
693− liftIO $ "Remove import" @=? actionTitle
694− executeCodeAction action
695− contentAfterAction <- documentContents docB
696− let expectedContentAfterAction = T.unlines
697− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
698− , "module ModuleB where"
699− , "stuffB :: Integer"
700− , "stuffB = 123"
701− ]
702− liftIO $ expectedContentAfterAction @=? contentAfterAction
703− , testSession "redundant binding" $ do
704− let contentA = T.unlines
705− [ "module ModuleA where"
706− , "stuffA = False"
707− , "stuffB :: Integer"
708− , "stuffB = 123"
709− , "stuffC = ()"
710− ]
711− _docA <- createDoc "ModuleA.hs" "haskell" contentA
712− let contentB = T.unlines
713− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714− , "module ModuleB where"
715− , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716− , "main = print stuffB"
717− ]
718− docB <- createDoc "ModuleB.hs" "haskell" contentB
719− _ <- waitForDiagnostics
720− [CACodeAction action@CodeAction { _title = actionTitle }]
721− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
722− liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
723− executeCodeAction action
724− contentAfterAction <- documentContents docB
725− let expectedContentAfterAction = T.unlines
726− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
727− , "module ModuleB where"
728− , "import ModuleA (stuffB)"
729− , "main = print stuffB"
730− ]
731− liftIO $ expectedContentAfterAction @=? contentAfterAction
732− , testSession "redundant operator" $ do
733− let contentA = T.unlines
734− [ "module ModuleA where"
735− , "a !! b = a"
736− , "a <?> b = a"
737− , "stuffB :: Integer"
738− , "stuffB = 123"
739− ]
740− _docA <- createDoc "ModuleA.hs" "haskell" contentA
741− let contentB = T.unlines
742− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743− , "module ModuleB where"
744− , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745− , "main = print A.stuffB"
746− ]
747− docB <- createDoc "ModuleB.hs" "haskell" contentB
748− _ <- waitForDiagnostics
749− [CACodeAction action@CodeAction { _title = actionTitle }]
750− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
751− liftIO $ "Remove !!, <?> from import" @=? actionTitle
752− executeCodeAction action
753− contentAfterAction <- documentContents docB
754− let expectedContentAfterAction = T.unlines
755− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756− , "module ModuleB where"
757− , "import qualified ModuleA as A (stuffB)"
758− , "main = print A.stuffB"
759− ]
760− liftIO $ expectedContentAfterAction @=? contentAfterAction
761− , testSession "redundant all import" $ do
762− let contentA = T.unlines
763− [ "module ModuleA where"
764− , "data A = A"
765− , "stuffB :: Integer"
766− , "stuffB = 123"
767− ]
768− _docA <- createDoc "ModuleA.hs" "haskell" contentA
769− let contentB = T.unlines
770− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771− , "module ModuleB where"
772− , "import ModuleA (A(..), stuffB)"
773− , "main = print stuffB"
774− ]
775− docB <- createDoc "ModuleB.hs" "haskell" contentB
776− _ <- waitForDiagnostics
777− [CACodeAction action@CodeAction { _title = actionTitle }]
778− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
779− liftIO $ "Remove A from import" @=? actionTitle
780− executeCodeAction action
781− contentAfterAction <- documentContents docB
782− let expectedContentAfterAction = T.unlines
783− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
784− , "module ModuleB where"
785− , "import ModuleA (stuffB)"
786− , "main = print stuffB"
787− ]
788− liftIO $ expectedContentAfterAction @=? contentAfterAction
789− , testSession "redundant constructor import" $ do
790− let contentA = T.unlines
791− [ "module ModuleA where"
792− , "data D = A | B"
793− , "data E = F"
794− ]
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))"
800− , "main = B"
801− ]
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))"
813− , "main = B"
814− ]
815− liftIO $ expectedContentAfterAction @=? contentAfterAction
816− ]
817−
818−extendImportTests :: TestTree
819−extendImportTests = testGroup "extend import actions"
820− [ testSession "extend single line import with value" $ template
821− (T.unlines
822− [ "module ModuleA where"
823− , "stuffA :: Double"
824− , "stuffA = 0.00750"
825− , "stuffB :: Integer"
826− , "stuffB = 123"
827− ])
828− (T.unlines
829− [ "module ModuleB where"
830− , "import ModuleA as A (stuffB)"
831− , "main = print (stuffA, stuffB)"
832− ])
833− (Range (Position 3 17) (Position 3 18))
834− "Add stuffA to the import list of ModuleA"
835− (T.unlines
836− [ "module ModuleB where"
837− , "import ModuleA as A (stuffA, stuffB)"
838− , "main = print (stuffA, stuffB)"
839− ])
840− , testSession "extend single line import with operator" $ template
841− (T.unlines
842− [ "module ModuleA where"
843− , "(.*) :: Integer -> Integer -> Integer"
844− , "x .* y = x * y"
845− , "stuffB :: Integer"
846− , "stuffB = 123"
847− ])
848− (T.unlines
849− [ "module ModuleB where"
850− , "import ModuleA as A (stuffB)"
851− , "main = print (stuffB .* stuffB)"
852− ])
853− (Range (Position 3 17) (Position 3 18))
854− "Add .* to the import list of ModuleA"
855− (T.unlines
856− [ "module ModuleB where"
857− , "import ModuleA as A ((.*), stuffB)"
858− , "main = print (stuffB .* stuffB)"
859− ])
860− , testSession "extend single line import with type" $ template
861− (T.unlines
862− [ "module ModuleA where"
863− , "type A = Double"
864− ])
865− (T.unlines
866− [ "module ModuleB where"
867− , "import ModuleA ()"
868− , "b :: A"
869− , "b = 0"
870− ])
871− (Range (Position 2 5) (Position 2 5))
872− "Add A to the import list of ModuleA"
873− (T.unlines
874− [ "module ModuleB where"
875− , "import ModuleA (A)"
876− , "b :: A"
877− , "b = 0"
878− ])
879− , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template
880− (T.unlines
881− [ "module ModuleA where"
882− , "data A = Constructor"
883− ])
884− (T.unlines
885− [ "module ModuleB where"
886− , "import ModuleA (A)"
887− , "b :: A"
888− , "b = Constructor"
889− ])
890− (Range (Position 2 5) (Position 2 5))
891− "Add Constructor to the import list of ModuleA"
892− (T.unlines
893− [ "module ModuleB where"
894− , "import ModuleA (A(Constructor))"
895− , "b :: A"
896− , "b = Constructor"
897− ])
898− , testSession "extend single line qualified import with value" $ template
899− (T.unlines
900− [ "module ModuleA where"
901− , "stuffA :: Double"
902− , "stuffA = 0.00750"
903− , "stuffB :: Integer"
904− , "stuffB = 123"
905− ])
906− (T.unlines
907− [ "module ModuleB where"
908− , "import qualified ModuleA as A (stuffB)"
909− , "main = print (A.stuffA, A.stuffB)"
910− ])
911− (Range (Position 3 17) (Position 3 18))
912− "Add stuffA to the import list of ModuleA"
913− (T.unlines
914− [ "module ModuleB where"
915− , "import qualified ModuleA as A (stuffA, stuffB)"
916− , "main = print (A.stuffA, A.stuffB)"
917− ])
918− , testSession "extend multi line import with value" $ template
919− (T.unlines
920− [ "module ModuleA where"
921− , "stuffA :: Double"
922− , "stuffA = 0.00750"
923− , "stuffB :: Integer"
924− , "stuffB = 123"
925− ])
926− (T.unlines
927− [ "module ModuleB where"
928− , "import ModuleA (stuffB"
929− , " )"
930− , "main = print (stuffA, stuffB)"
931− ])
932− (Range (Position 3 17) (Position 3 18))
933− "Add stuffA to the import list of ModuleA"
934− (T.unlines
935− [ "module ModuleB where"
936− , "import ModuleA (stuffA, stuffB"
937− , " )"
938− , "main = print (stuffA, stuffB)"
939− ])
940− ]
941− where
942− template contentA contentB range expectedAction expectedContentB = do
943− _docA <- createDoc "ModuleA.hs" "haskell" contentA
944− docB <- createDoc "ModuleB.hs" "haskell" contentB
945− _ <- waitForDiagnostics
946− CACodeAction action@CodeAction { _title = actionTitle } : _
947− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
948− getCodeActions docB range
949− liftIO $ expectedAction @=? actionTitle
950− executeCodeAction action
951− contentAfterAction <- documentContents docB
952− liftIO $ expectedContentB @=? contentAfterAction
953−
954−suggestImportTests :: TestTree
955−suggestImportTests = testGroup "suggest import actions"
956− [ testGroup "Dont want suggestion"
957− [ -- extend import
958− test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
959− -- data constructor
960− , test False [] "f = First" [] "import Data.Monoid (First)"
961− -- internal module
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)"
965− ]
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 ((&))"
986− ]
987− ]
988− where
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
999− if wanted
1000− then do
1001− action <- liftIO $ pickActionWithTitle newImp actions
1002− executeCodeAction action
1003− contentAfterAction <- documentContents doc
1004− liftIO $ after @=? contentAfterAction
1005− else
1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007−
1008−
1009−addExtensionTests :: TestTree
1010−addExtensionTests = testGroup "add language extension actions"
1011− [ testSession "add NamedFieldPuns language extension" $ template
1012− (T.unlines
1013− [ "module Module where"
1014− , ""
1015− , "data A = A { getA :: Bool }"
1016− , ""
1017− , "f :: A -> Bool"
1018− , "f A { getA } = getA"
1019− ])
1020− (Range (Position 0 0) (Position 0 0))
1021− "Add NamedFieldPuns extension"
1022− (T.unlines
1023− [ "{-# LANGUAGE NamedFieldPuns #-}"
1024− , "module Module where"
1025− , ""
1026− , "data A = A { getA :: Bool }"
1027− , ""
1028− , "f :: A -> Bool"
1029− , "f A { getA } = getA"
1030− ])
1031− , testSession "add RecordWildCards language extension" $ template
1032− (T.unlines
1033− [ "module Module where"
1034− , ""
1035− , "data A = A { getA :: Bool }"
1036− , ""
1037− , "f :: A -> Bool"
1038− , "f A { .. } = getA"
1039− ])
1040− (Range (Position 0 0) (Position 0 0))
1041− "Add RecordWildCards extension"
1042− (T.unlines
1043− [ "{-# LANGUAGE RecordWildCards #-}"
1044− , "module Module where"
1045− , ""
1046− , "data A = A { getA :: Bool }"
1047− , ""
1048− , "f :: A -> Bool"
1049− , "f A { .. } = getA"
1050− ])
1051− ]
1052− where
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
1063−
1064−
1065−insertNewDefinitionTests :: TestTree
1066−insertNewDefinitionTests = testGroup "insert new definition actions"
1067− [ testSession "insert new function definition" $ do
1068− let txtB =
1069− ["foo True = select [True]"
1070− , ""
1071− ,"foo False = False"
1072− ]
1073− txtB' =
1074− [""
1075− ,"someOtherCode = ()"
1076− ]
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 ++
1086− [ ""
1087− , "select :: [Bool] -> Bool"
1088− , "select = error \"not implemented\""
1089− ]
1090− ++ txtB')
1091− , testSession "define a hole" $ do
1092− let txtB =
1093− ["foo True = _select [True]"
1094− , ""
1095− ,"foo False = False"
1096− ]
1097− txtB' =
1098− [""
1099− ,"someOtherCode = ()"
1100− ]
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]"
1111− , ""
1112− ,"foo False = False"
1113− , ""
1114− , "select :: [Bool] -> Bool"
1115− , "select = error \"not implemented\""
1116− ]
1117− ++ txtB')
1118− ]
1119−
1120−fixConstructorImportTests :: TestTree
1121−fixConstructorImportTests = testGroup "fix import actions"
1122− [ testSession "fix constructor import" $ template
1123− (T.unlines
1124− [ "module ModuleA where"
1125− , "data A = Constructor"
1126− ])
1127− (T.unlines
1128− [ "module ModuleB where"
1129− , "import ModuleA(Constructor)"
1130− ])
1131− (Range (Position 1 10) (Position 1 11))
1132− "Fix import of A(Constructor)"
1133− (T.unlines
1134− [ "module ModuleB where"
1135− , "import ModuleA(A(Constructor))"
1136− ])
1137− ]
1138− where
1139− template contentA contentB range expectedAction expectedContentB = do
1140− _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141− docB <- createDoc "ModuleB.hs" "haskell" contentB
1142− _diags <- waitForDiagnostics
1143− CACodeAction action@CodeAction { _title = actionTitle } : _
1144− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1145− getCodeActions docB range
1146− liftIO $ expectedAction @=? actionTitle
1147− executeCodeAction action
1148− contentAfterAction <- documentContents docB
1149− liftIO $ expectedContentB @=? contentAfterAction
1150−
1151−importRenameActionTests :: TestTree
1152−importRenameActionTests = testGroup "import rename actions"
1153− [ testSession "Data.Mape -> Data.Map" $ check "Map"
1154− , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where
1155− check modname = do
1156− let content = T.unlines
1157− [ "module Testing where"
1158− , "import Data.Mape"
1159− ]
1160− doc <- createDoc "Testing.hs" "haskell" content
1161− _ <- waitForDiagnostics
1162− actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1163− let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1164− executeCodeAction changeToMap
1165− contentAfterAction <- documentContents doc
1166− let expectedContentAfterAction = T.unlines
1167− [ "module Testing where"
1168− , "import Data." <> modname
1169− ]
1170− liftIO $ expectedContentAfterAction @=? contentAfterAction
1171−
1172−fillTypedHoleTests :: TestTree
1173−fillTypedHoleTests = let
1174−
1175− sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
1176− sourceCode a b c = T.unlines
1177− [ "module Testing where"
1178− , ""
1179− , "globalConvert :: Int -> String"
1180− , "globalConvert = undefined"
1181− , ""
1182− , "globalInt :: Int"
1183− , "globalInt = 3"
1184− , ""
1185− , "bar :: Int -> Int -> String"
1186− , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"
1187− , " localConvert = (flip replicate) 'x'"
1188−
1189− ]
1190−
1191− check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
1192− check actionTitle
1193− oldA oldB oldC
1194− newA newB newC = testSession (T.unpack actionTitle) $ do
1195− let originalCode = sourceCode oldA oldB oldC
1196− let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
1198− _ <- waitForDiagnostics
1199− actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1201− executeCodeAction chosenAction
1202− modifiedCode <- documentContents doc
1203− liftIO $ expectedCode @=? modifiedCode
1204− in
1205− testGroup "fill typed holes"
1206− [ check "replace hole `_` with show"
1207− "_" "n" "n"
1208− "show" "n" "n"
1209−
1210− , check "replace hole `_` with globalConvert"
1211− "_" "n" "n"
1212− "globalConvert" "n" "n"
1213−
1214−#if MIN_GHC_API_VERSION(8,6,0)
1215− , check "replace hole `_convertme` with localConvert"
1216− "_convertme" "n" "n"
1217− "localConvert" "n" "n"
1218−#endif
1219−
1220− , check "replace hole `_b` with globalInt"
1221− "_a" "_b" "_c"
1222− "_a" "globalInt" "_c"
1223−
1224− , check "replace hole `_c` with globalInt"
1225− "_a" "_b" "_c"
1226− "_a" "_b" "globalInt"
1227−
1228−#if MIN_GHC_API_VERSION(8,6,0)
1229− , check "replace hole `_c` with parameterInt"
1230− "_a" "_b" "_c"
1231− "_a" "_b" "parameterInt"
1232−#endif
1233− ]
1234−
1235−addSigActionTests :: TestTree
1236−addSigActionTests = let
1237− header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
1238− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1239− before def = T.unlines [header, moduleH, def]
1240− after' def sig = T.unlines [header, moduleH, sig, def]
1241−
1242− def >:: sig = testSession (T.unpack def) $ do
1243− let originalCode = before def
1244− let expectedCode = after' def sig
1245− doc <- createDoc "Sigs.hs" "haskell" originalCode
1246− _ <- waitForDiagnostics
1247− actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1248− chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1249− executeCodeAction chosenAction
1250− modifiedCode <- documentContents doc
1251− liftIO $ expectedCode @=? modifiedCode
1252− in
1253− testGroup "add signature"
1254− [ "abc = True" >:: "abc :: Bool"
1255− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1256− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1257− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1258− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1259− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260− , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1261− ]
1262−
1263−addSigLensesTests :: TestTree
1264−addSigLensesTests = let
1265− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1266− notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1267− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1268− other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1269− before withMissing def
1270− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1271− after' withMissing def sig
1272− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
1273−
1274− sigSession withMissing def sig = testSession (T.unpack def) $ do
1275− let originalCode = before withMissing def
1276− let expectedCode = after' withMissing def sig
1277− doc <- createDoc "Sigs.hs" "haskell" originalCode
1278− [CodeLens {_command = Just c}] <- getCodeLenses doc
1279− executeCommand c
1280− modifiedCode <- getDocumentEdit doc
1281− liftIO $ expectedCode @=? modifiedCode
1282− in
1283− testGroup "add signature"
1284− [ testGroup title
1285− [ sigSession enableWarnings "abc = True" "abc :: Bool"
1286− , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1287− , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1288− , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1289− , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1290− , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1291− , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1292− ]
1293− | (title, enableWarnings) <-
1294− [("with warnings enabled", True)
1295− ,("with warnings disabled", False)
1296− ]
1297− ]
1298−
1299−checkDefs :: [Location] -> Session [Expect] -> Session ()
1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1301−
1302− check (ExpectRange expectedRange) = do
1303− assertNDefinitionsFound 1 defs
1304− assertRangeCorrect (head defs) expectedRange
1305− check (ExpectLocation expectedLocation) = do
1306− assertNDefinitionsFound 1 defs
1307− liftIO $ head defs @?= expectedLocation
1308− check ExpectNoDefinitions = do
1309− assertNDefinitionsFound 0 defs
1310− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311− check _ = pure () -- all other expectations not relevant to getDefinition
1312−
1313− assertNDefinitionsFound :: Int -> [a] -> Session ()
1314− assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1315−
1316− assertRangeCorrect Location{_range = foundRange} expectedRange =
1317− liftIO $ expectedRange @=? foundRange
1318−
1319−
1320−findDefinitionAndHoverTests :: TestTree
1321−findDefinitionAndHoverTests = let
1322−
1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324− doc <- openTestDataDoc (dir </> sourceFilePath)
1325− found <- get doc pos
1326− check found targetRange
1327−
1328−
1329−
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
1332−
1333− check expected =
1334− case hover of
1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
1336− Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1337− ,_range = rangeInHover } ->
1338− case expected of
1339− ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340− ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1341− ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342− ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
1343− _ -> pure () -- all other expectations not relevant to hover
1344− _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1345−
1346− extractLineColFromHoverMsg :: T.Text -> [T.Text]
1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
1348−
1349− checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1350− checkHoverRange expectedRange rangeInHover msg =
1351− let
1352− lineCol = extractLineColFromHoverMsg msg
1353− -- looks like hovers use 1-based numbering while definitions use 0-based
1354− -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
1355− adjust Position{_line = l, _character = c} =
1356− Position{_line = l + 1, _character = c + 1}
1357− in
1358− case map (read . T.unpack) lineCol of
1359− [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c
1360− _ -> liftIO $ assertFailure $
1361− "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
1362− "\n but got: " <> show (msg, rangeInHover)
1363−
1364− assertFoundIn :: T.Text -> T.Text -> Assertion
1365− assertFoundIn part whole = assertBool
1366− (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
1367− (part `T.isInfixOf` whole)
1368−
1369− sourceFilePath = T.unpack sourceFileName
1370− sourceFileName = "GotoHover.hs"
1371−
1372− mkFindTests tests = testGroup "get"
1373− [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
1375− , checkFileCompiles sourceFilePath ]
1376−
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
1378−
1379− testM runDef runHover look expect title =
1380− ( runDef $ tst def look expect title
1381− , runHover $ tst hover look expect title ) where
1382− def = (getDefinitions, checkDefs)
1383− hover = (getHover , checkHover)
1384− --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1385−
1386− -- search locations expectations on results
1387− fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1388− fffL8 = Position 12 4 ;
1389− fffL14 = Position 18 7 ;
1390− aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1391− dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1392− dcL12 = Position 16 11 ;
1393− xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1394− tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1395− vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1396− opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1397− opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1398− aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1399− b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1400− xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1401− clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1402− clL25 = Position 29 9
1403− eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1404− dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1405− dnbL30 = Position 34 23
1406− lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1407− lclL33 = Position 37 22
1408− mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409− mclL37 = Position 41 1
1410− spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411− docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1412− ; constr = [ExpectHoverText ["Monad m"]]
1413− eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414− intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415− tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416− intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417− chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418− txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419− lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420− outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421− innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422− imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423− reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
1424− in
1425− mkFindTests
1426− -- def hover look expect
1427− [ test yes yes fffL4 fff "field in record definition"
1428− , test broken broken fffL8 fff "field in record construction #71"
1429− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430− , test yes yes aaaL14 aaa "top-level name" -- 120
1431− , test yes yes dcL7 tcDC "data constructor record #247"
1432− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1433− , test yes yes tcL6 tcData "type constructor #248" -- 147
1434− , test broken yes xtcL5 xtc "type constructor external #248,249"
1435− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1436− , test yes yes vvL16 vv "plain parameter" -- 120
1437− , test yes yes aL18 apmp "pattern match name" -- 120
1438− , test yes yes opL16 op "top-level operator" -- 120, 123
1439− , test yes yes opL18 opp "parameter operator" -- 120
1440− , test yes yes b'L19 bp "name in backticks" -- 120
1441− , test yes yes clL23 cls "class in instance declaration #250"
1442− , test yes yes clL25 cls "class in signature #250" -- 147
1443− , test broken yes eclL15 ecls "external class in signature #249,250"
1444− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445− , test yes yes dnbL30 dnb "do-notation lookup"
1446− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447− , test yes yes lclL33 lcb "listcomp lookup"
1448− , test yes yes mclL36 mcl "top-level fn 1st clause"
1449− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450− , test yes yes spaceL37 space "top-level fn on space #315"
1451− , test no broken docL41 doc "documentation #7"
1452− , test no yes eitL40 kindE "kind of Either #273"
1453− , test no yes intL40 kindI "kind of Int #273"
1454− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455− , test no yes intL41 litI "literal Int in hover info #274"
1456− , test no yes chrL36 litC "literal Char in hover info #274"
1457− , test no yes txtL8 litT "literal Text in hover info #274"
1458− , test no yes lstL43 litL "literal List in hover info #274"
1459− , test no yes docL41 constr "type constraint in hover info #283"
1460− , test broken broken outL45 outSig "top-level signature #310"
1461− , test broken broken innL48 innSig "inner signature #310"
1462− , testM yes yes imported importedSig "Imported symbol"
1463− , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
1464− ]
1465− where yes, broken :: (TestTree -> Maybe TestTree)
1466− yes = Just -- test should run and pass
1467− broken = Just . (`xfail` "known broken")
1468− no = const Nothing -- don't run this test at all
1469−
1470−checkFileCompiles :: FilePath -> TestTree
1471−checkFileCompiles fp =
1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473− void (openTestDataDoc (dir </> fp))
1474− expectNoMoreDiagnostics 0.5
1475−
1476−
1477−
1478−pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
1481− let content =
1482− T.unlines
1483− [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1484− , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"
1485− , "module Testing where"
1486− , "import Data.Proxy"
1487− , "import GHC.TypeLits"
1488− -- This function fails without plugins being initialized.
1489− , "f :: forall n. KnownNat n => Proxy n -> Integer"
1490− , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"
1491− , "foo :: Int -> Int -> Int"
1492− , "foo a b = a + c"
1493− ]
1494− _ <- createDoc "Testing.hs" "haskell" content
1495− expectDiagnostics
1496− [ ( "Testing.hs",
1497− [(DsError, (8, 14), "Variable not in scope: c")]
1498− )
1499− ]
1500−
1501−cppTests :: TestTree
1502−cppTests =
1503− testGroup "cpp"
1504− [ testCase "cpp-error" $ do
1505− let content =
1506− T.unlines
1507− [ "{-# LANGUAGE CPP #-}",
1508− "module Testing where",
1509− "#ifdef FOO",
1510− "foo = 42"
1511− ]
1512− -- The error locations differ depending on which C-preprocessor is used.
1513− -- Some give the column number and others don't (hence -1). Assert either
1514− -- of them.
1515− (run $ expectError content (2, -1))
1516− `catch` ( \e -> do
1517− let _ = e :: HUnitFailure
1518− run $ expectError content (2, 1)
1519− )
1520− , testSessionWait "cpp-ghcide" $ do
1521− _ <- createDoc "A.hs" "haskell" $ T.unlines
1522− ["{-# LANGUAGE CPP #-}"
1523− ,"main ="
1524− ,"#ifdef __GHCIDE__"
1525− ," worked"
1526− ,"#else"
1527− ," failed"
1528− ,"#endif"
1529− ]
1530− expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1531− ]
1532− where
1533− expectError :: T.Text -> Cursor -> Session ()
1534− expectError content cursor = do
1535− _ <- createDoc "Testing.hs" "haskell" content
1536− expectDiagnostics
1537− [ ( "Testing.hs",
1538− [(DsError, cursor, "error: unterminated")]
1539− )
1540− ]
1541− expectNoMoreDiagnostics 0.5
1542−
1543−preprocessorTests :: TestTree
1544−preprocessorTests = testSessionWait "preprocessor" $ do
1545− let content =
1546− T.unlines
1547− [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
1548− , "module Testing where"
1549− , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1550− ]
1551− _ <- createDoc "Testing.hs" "haskell" content
1552− expectDiagnostics
1553− [ ( "Testing.hs",
1554− [(DsError, (2, 8), "Variable not in scope: z")]
1555− )
1556− ]
1557−
1558−
1559−safeTests :: TestTree
1560−safeTests =
1561− testGroup
1562− "SafeHaskell"
1563− [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564− testSessionWait "load" $ do
1565− let sourceA =
1566− T.unlines
1567− ["{-# LANGUAGE Trustworthy #-}"
1568− ,"module A where"
1569− ,"import System.IO.Unsafe"
1570− ,"import System.IO"
1571− ,"trustWorthyId :: a -> a"
1572− ,"trustWorthyId i = unsafePerformIO $ do"
1573− ," putStrLn \"I'm safe\""
1574− ," return i"]
1575− sourceB =
1576− T.unlines
1577− ["{-# LANGUAGE Safe #-}"
1578− ,"module B where"
1579− ,"import A"
1580− ,"safeId :: a -> a"
1581− ,"safeId = trustWorthyId"
1582− ]
1583−
1584− _ <- createDoc "A.hs" "haskell" sourceA
1585− _ <- createDoc "B.hs" "haskell" sourceB
1586− expectNoMoreDiagnostics 1 ]
1587−
1588−thTests :: TestTree
1589−thTests =
1590− testGroup
1591− "TemplateHaskell"
1592− [ -- Test for https://github.com/digital-asset/ghcide/pull/212
1593− testSessionWait "load" $ do
1594− let sourceA =
1595− T.unlines
1596− [ "{-# LANGUAGE PackageImports #-}",
1597− "{-# LANGUAGE TemplateHaskell #-}",
1598− "module A where",
1599− "import \"template-haskell\" Language.Haskell.TH",
1600− "a :: Integer",
1601− "a = $(litE $ IntegerL 3)"
1602− ]
1603− sourceB =
1604− T.unlines
1605− [ "{-# LANGUAGE PackageImports #-}",
1606− "{-# LANGUAGE TemplateHaskell #-}",
1607− "module B where",
1608− "import A",
1609− "import \"template-haskell\" Language.Haskell.TH",
1610− "b :: Integer",
1611− "b = $(litE $ IntegerL $ a) + n"
1612− ]
1613− _ <- createDoc "A.hs" "haskell" sourceA
1614− _ <- createDoc "B.hs" "haskell" sourceB
1615− expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616− , testSessionWait "newtype-closure" $ do
1617− let sourceA =
1618− T.unlines
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)"
1625− ,"a :: ExpQ"
1626− ,"a = [| 0 |]"]
1627− let sourceB =
1628− T.unlines
1629− [ "{-# LANGUAGE TemplateHaskell #-}"
1630− ,"module B where"
1631− ,"import A"
1632− ,"b :: Int"
1633− ,"b = $( a )" ]
1634− _ <- createDoc "A.hs" "haskell" sourceA
1635− _ <- createDoc "B.hs" "haskell" sourceB
1636− return ()
1637− ]
1638−
1639−completionTests :: TestTree
1640−completionTests
1641− = testGroup "completion"
1642− [ testSessionWait "variable" $ do
1643− let source = T.unlines ["module A where", "f = hea"]
1644− docId <- createDoc "A.hs" "haskell" source
1645− compls <- getCompletions docId (Position 1 7)
1646− liftIO $ map dropDocs compls @?=
1647− [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1648− let [CompletionItem { _documentation = headDocs}] = compls
1649− checkDocText "head" headDocs [ "Defined in 'Prelude'"
1650−#if MIN_GHC_API_VERSION(8,6,5)
1651− , "Extract the first element of a list"
1652−#endif
1653− ]
1654− , testSessionWait "constructor" $ do
1655− let source = T.unlines ["module A where", "f = Tru"]
1656− docId <- createDoc "A.hs" "haskell" source
1657− compls <- getCompletions docId (Position 1 7)
1658− liftIO $ map dropDocs compls @?=
1659− [ complItem "True" (Just CiConstructor) (Just "Bool")
1660−#if MIN_GHC_API_VERSION(8,6,0)
1661− , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1662−#else
1663− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1664−#endif
1665− ]
1666− , testSessionWait "type" $ do
1667− let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668− docId <- createDoc "A.hs" "haskell" source
1669− expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1670− changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1671− compls <- getCompletions docId (Position 2 7)
1672− liftIO $ map dropDocs compls @?=
1673− [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")
1674− , complItem "Bool" (Just CiStruct) (Just "*") ]
1675− let [ CompletionItem { _documentation = boundedDocs},
1676− CompletionItem { _documentation = boolDocs } ] = compls
1677− checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1678−#if MIN_GHC_API_VERSION(8,6,5)
1679− , "name the upper and lower limits"
1680−#endif
1681− ]
1682− checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1683− , testSessionWait "qualified" $ do
1684− let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685− docId <- createDoc "A.hs" "haskell" source
1686− expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1687− changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1688− compls <- getCompletions docId (Position 2 15)
1689− liftIO $ map dropDocs compls @?=
1690− [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1691− let [CompletionItem { _documentation = headDocs}] = compls
1692− checkDocText "head" headDocs [ "Defined in 'Prelude'"
1693−#if MIN_GHC_API_VERSION(8,6,5)
1694− , "Extract the first element of a list"
1695−#endif
1696− ]
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"
1706− , "f = f"
1707− ]
1708− docId <- createDoc "A.hs" "haskell" source
1709− expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710− changeDoc docId
1711− [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712− [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713− , "module A () where"
1714− , "f = f"
1715− , "g :: Intege"
1716− ]
1717− ]
1718− -- At this point the module parses but does not typecheck.
1719− -- This should be sufficient to detect that we are in a
1720− -- type context and only show the completion to the type.
1721− compls <- getCompletions docId (Position 3 11)
1722− liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1723− ]
1724− where
1725− dropDocs :: CompletionItem -> CompletionItem
1726− dropDocs ci = ci { _documentation = Nothing }
1727− complItem label kind ty = CompletionItem
1728− { _label = label
1729− , _kind = kind
1730− , _tags = List []
1731− , _detail = (":: " <>) <$> ty
1732− , _documentation = Nothing
1733− , _deprecated = Nothing
1734− , _preselect = Nothing
1735− , _sortText = Nothing
1736− , _filterText = Nothing
1737− , _insertText = Nothing
1738− , _insertTextFormat = Just PlainText
1739− , _textEdit = Nothing
1740− , _additionalTextEdits = Nothing
1741− , _commitCharacters = Nothing
1742− , _command = Nothing
1743− , _xdata = Nothing
1744− }
1745− keywordItem label = CompletionItem
1746− { _label = label
1747− , _kind = Just CiKeyword
1748− , _tags = List []
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
1761− , _xdata = Nothing
1762− }
1763− getDocText (CompletionDocString s) = s
1764− getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1765− checkDocText thing Nothing _
1766− = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"
1767− checkDocText thing (Just doc) items
1768− = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $
1769− all (`T.isInfixOf` getDocText doc) items
1770−
1771−outlineTests :: TestTree
1772−outlineTests = testGroup
1773− "outline"
1774− [ testSessionWait "type class" $ do
1775− let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776− docId <- createDoc "A.hs" "haskell" source
1777− symbols <- getDocumentSymbols docId
1778− liftIO $ symbols @?= Left
1779− [ moduleSymbol
1780− "A"
1781− (R 0 7 0 8)
1782− [ classSymbol "A a"
1783− (R 1 0 1 30)
1784− [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
1785− ]
1786− ]
1787− , testSessionWait "type class instance " $ do
1788− let source = T.unlines ["class A a where", "instance A () where"]
1789− docId <- createDoc "A.hs" "haskell" source
1790− symbols <- getDocumentSymbols docId
1791− liftIO $ symbols @?= Left
1792− [ classSymbol "A a" (R 0 0 0 15) []
1793− , docSymbol "A ()" SkInterface (R 1 0 1 19)
1794− ]
1795− , testSessionWait "type family" $ do
1796− let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797− docId <- createDoc "A.hs" "haskell" source
1798− symbols <- getDocumentSymbols docId
1799− liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1800− , testSessionWait "type family instance " $ do
1801− let source = T.unlines
1802− [ "{-# language TypeFamilies #-}"
1803− , "type family A a"
1804− , "type instance A () = ()"
1805− ]
1806− docId <- createDoc "A.hs" "haskell" source
1807− symbols <- getDocumentSymbols docId
1808− liftIO $ symbols @?= Left
1809− [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1810− , docSymbol "A ()" SkInterface (R 2 0 2 23)
1811− ]
1812− , testSessionWait "data family" $ do
1813− let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814− docId <- createDoc "A.hs" "haskell" source
1815− symbols <- getDocumentSymbols docId
1816− liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1817− , testSessionWait "data family instance " $ do
1818− let source = T.unlines
1819− [ "{-# language TypeFamilies #-}"
1820− , "data family A a"
1821− , "data instance A () = A ()"
1822− ]
1823− docId <- createDoc "A.hs" "haskell" source
1824− symbols <- getDocumentSymbols docId
1825− liftIO $ symbols @?= Left
1826− [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1827− , docSymbol "A ()" SkInterface (R 2 0 2 25)
1828− ]
1829− , testSessionWait "constant" $ do
1830− let source = T.unlines ["a = ()"]
1831− docId <- createDoc "A.hs" "haskell" source
1832− symbols <- getDocumentSymbols docId
1833− liftIO $ symbols @?= Left
1834− [docSymbol "a" SkFunction (R 0 0 0 6)]
1835− , testSessionWait "pattern" $ do
1836− let source = T.unlines ["Just foo = Just 21"]
1837− docId <- createDoc "A.hs" "haskell" source
1838− symbols <- getDocumentSymbols docId
1839− liftIO $ symbols @?= Left
1840− [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1841− , testSessionWait "pattern with type signature" $ do
1842− let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843− docId <- createDoc "A.hs" "haskell" source
1844− symbols <- getDocumentSymbols docId
1845− liftIO $ symbols @?= Left
1846− [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1847− , testSessionWait "function" $ do
1848− let source = T.unlines ["a x = ()"]
1849− docId <- createDoc "A.hs" "haskell" source
1850− symbols <- getDocumentSymbols docId
1851− liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1852− , testSessionWait "type synonym" $ do
1853− let source = T.unlines ["type A = Bool"]
1854− docId <- createDoc "A.hs" "haskell" source
1855− symbols <- getDocumentSymbols docId
1856− liftIO $ symbols @?= Left
1857− [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1858− , testSessionWait "datatype" $ do
1859− let source = T.unlines ["data A = C"]
1860− docId <- createDoc "A.hs" "haskell" source
1861− symbols <- getDocumentSymbols docId
1862− liftIO $ symbols @?= Left
1863− [ docSymbolWithChildren "A"
1864− SkStruct
1865− (R 0 0 0 10)
1866− [docSymbol "C" SkConstructor (R 0 9 0 10)]
1867− ]
1868− , testSessionWait "record fields" $ do
1869− let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870− docId <- createDoc "A.hs" "haskell" source
1871− symbols <- getDocumentSymbols docId
1872− liftIO $ symbols @=? Left
1873− [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874− [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875− [ docSymbol "x" SkField (R 1 2 1 3)
1876− , docSymbol "y" SkField (R 2 4 2 5)
1877− ]
1878− ]
1879− ]
1880− , testSessionWait "import" $ do
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"
1886− SkModule
1887− (R 0 0 0 17)
1888− [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1889− ]
1890− ]
1891− , testSessionWait "multiple import" $ do
1892− let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893− docId <- createDoc "A.hs" "haskell" source
1894− symbols <- getDocumentSymbols docId
1895− liftIO $ symbols @?= Left
1896− [docSymbolWithChildren "imports"
1897− SkModule
1898− (R 1 0 3 24)
1899− [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900− , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1901− ]
1902− ]
1903− , testSessionWait "foreign import" $ do
1904− let source = T.unlines
1905− [ "{-# language ForeignFunctionInterface #-}"
1906− , "foreign import ccall \"a\" a :: Int"
1907− ]
1908− docId <- createDoc "A.hs" "haskell" source
1909− symbols <- getDocumentSymbols docId
1910− liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1911− , testSessionWait "foreign export" $ do
1912− let source = T.unlines
1913− [ "{-# language ForeignFunctionInterface #-}"
1914− , "foreign export ccall odd :: Int -> Bool"
1915− ]
1916− docId <- createDoc "A.hs" "haskell" source
1917− symbols <- getDocumentSymbols docId
1918− liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1919183 ]
1920− where
1921− docSymbol name kind loc =
1922− DocumentSymbol name Nothing kind Nothing loc loc Nothing
1923− docSymbol' name kind loc selectionLoc =
1924− DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing
1925− docSymbolD name detail kind loc =
1926− DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1927− docSymbolWithChildren name kind loc 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)
1931− moduleSymbol name loc cc = DocumentSymbol name
1932− Nothing
1933− SkFile
1934− Nothing
1935− (R 0 0 maxBound 0)
1936− loc
1937− (Just $ List cc)
1938− classSymbol name loc cc = DocumentSymbol name
1939− (Just "class")
1940− SkClass
1941− Nothing
1942− loc
1943− loc
1944− (Just $ List cc)
1945−
1946−pattern R :: Int -> Int -> Int -> Int -> Range
1947−pattern R x y x' y' = Range (Position x y) (Position x' y')
1948−
1949−xfail :: TestTree -> String -> TestTree
1950−xfail = flip expectFailBecause
1951−
1952−xfail8101 :: TestTree -> String -> TestTree
1953−#if MIN_GHC_API_VERSION(8,10,0)
1954−xfail8101 = flip expectFailBecause
1955−#else
1956−xfail8101 t _ = t
1957−#endif
1958−
1959−data Expect
1960− = ExpectRange Range -- Both gotoDef and hover should report this range
1961− | ExpectLocation Location
1962−-- | ExpectDefRange Range -- Only gotoDef should report this range
1963− | ExpectHoverRange Range -- Only hover should report this range
1964− | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1965− | ExpectExternFail -- definition lookup in other file expected to fail
1966− | ExpectNoDefinitions
1967− | ExpectNoHover
1968−-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1969− deriving Eq
1970−
1971−mkR :: Int -> Int -> Int -> Int -> Expect
1972−mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1973−
1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976−
1977−haddockTests :: TestTree
1978−haddockTests
1979− = testGroup "haddock"
1980− [ testCase "Num" $ checkHaddock
1981− (unlines
1982− [ "However, '(+)' and '(*)' are"
1983− , "customarily expected to define a ring and have the following properties:"
1984− , ""
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@"
1988− ]
1989− )
1990− (unlines
1991− [ ""
1992− , ""
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`"
1998− ]
1999− )
2000− , testCase "unsafePerformIO" $ checkHaddock
2001− (unlines
2002− [ "may require"
2003− , "different precautions:"
2004− , ""
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."
2008− , ""
2009− , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010− , " elimination being performed on the module."
2011− , ""
2012− ]
2013− )
2014− (unlines
2015− [ ""
2016− , ""
2017− , "may require"
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."
2022− , ""
2023− , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024− , " elimination being performed on the module."
2025− , ""
2026− ]
2027− )
2028− ]
2029− where
2030− checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2031−
2032−cradleTests :: TestTree
2033−cradleTests = testGroup "cradle"
2034− [testGroup "dependencies" [sessionDepsArePickedUp]
2035− ,testGroup "loading" [loadCradleOnlyonce]
2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2037− ]
2038−
2039−loadCradleOnlyonce :: TestTree
2040−loadCradleOnlyonce = testGroup "load cradle only once"
2041− [ testSession' "implicit" implicit
2042− , testSession' "direct" direct
2043− ]
2044− where
2045− direct dir = do
2046− liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047− "cradle: {direct: {arguments: []}}"
2048− test dir
2049− implicit dir = test dir
2050− test _dir = do
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
2060−
2061−
2062−dependentFileTest :: TestTree
2063−dependentFileTest = testGroup "addDependentFile"
2064− [testGroup "file-changed" [testSession' "test" test]
2065− ]
2066− where
2067− test dir = do
2068− -- If the file contains B then no type error
2069− -- otherwise type error
2070− liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071− let fooContent = T.unlines
2072− [ "{-# LANGUAGE TemplateHaskell #-}"
2073− , "module Foo where"
2074− , "import Language.Haskell.TH.Syntax"
2075− , "foo :: Int"
2076− , "foo = 1 + $(do"
2077− , " qAddDependentFile \"dep-file.txt\""
2078− , " f <- qRunIO (readFile \"dep-file.txt\")"
2079− , " if f == \"B\" then [| 1 |] else lift f)"
2080− ]
2081− let bazContent = T.unlines ["module Baz where", "import Foo"]
2082− _ <-createDoc "Foo.hs" "haskell" fooContent
2083− doc <- createDoc "Baz.hs" "haskell" bazContent
2084− expectDiagnostics
2085− [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086− -- Now modify the dependent file
2087− liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088− let change = TextDocumentContentChangeEvent
2089− { _range = Just (Range (Position 2 0) (Position 2 6))
2090− , _rangeLength = Nothing
2091− , _text = "f = ()"
2092− }
2093− -- Modifying Baz will now trigger Foo to be rebuilt as well
2094− changeDoc doc [change]
2095− expectDiagnostics [("Foo.hs", [])]
2096−
2097−
2098−cradleLoadedMessage :: Session FromServerMessage
2099−cradleLoadedMessage = satisfy $ \case
2100− NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2101− _ -> False
2102−
2103−cradleLoadedMethod :: T.Text
2104−cradleLoadedMethod = "ghcide/cradle/loaded"
2105−
2106−-- Stack sets this which trips up cabal in the multi-component tests.
2107−-- However, our plugin tests rely on those env vars so we unset it locally.
2108−withoutStackEnv :: IO a -> IO a
2109−withoutStackEnv s =
2110− bracket
2111− (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112− (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2113− (const s)
2114− where vars =
2115− [ "GHC_PACKAGE_PATH"
2116− , "GHC_ENVIRONMENT"
2117− , "HASKELL_DIST_DIR"
2118− , "HASKELL_PACKAGE_SANDBOX"
2119− , "HASKELL_PACKAGE_SANDBOXES"
2120− ]
2121− restore var Nothing = unsetEnv var
2122− restore var (Just val) = setEnv var val True
2123−
2124−simpleMultiTest :: TestTree
2125−simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126− let aPath = dir </> "a/A.hs"
2127− bPath = dir </> "b/B.hs"
2128− aSource <- liftIO $ readFileUtf8 aPath
2129− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130− expectNoMoreDiagnostics 0.5
2131− bSource <- liftIO $ readFileUtf8 bPath
2132− bdoc <- createDoc bPath "haskell" bSource
2133− expectNoMoreDiagnostics 0.5
2134− locs <- getDefinitions bdoc (Position 2 7)
2135− let fooL = mkL adoc 2 0 2 3
2136− checkDefs locs (pure [fooL])
2137− expectNoMoreDiagnostics 0.5
2138−
2139−-- Like simpleMultiTest but open the files in the other order
2140−simpleMultiTest2 :: TestTree
2141−simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142− let aPath = dir </> "a/A.hs"
2143− bPath = dir </> "b/B.hs"
2144− bSource <- liftIO $ readFileUtf8 bPath
2145− bdoc <- createDoc bPath "haskell" bSource
2146− expectNoMoreDiagnostics 5
2147− aSource <- liftIO $ readFileUtf8 aPath
2148− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149− -- Need to have some delay here or the test fails
2150− expectNoMoreDiagnostics 5
2151− locs <- getDefinitions bdoc (Position 2 7)
2152− let fooL = mkL adoc 2 0 2 3
2153− checkDefs locs (pure [fooL])
2154− expectNoMoreDiagnostics 0.5
2155−
2156−sessionDepsArePickedUp :: TestTree
2157−sessionDepsArePickedUp = testSession'
2158− "session-deps-are-picked-up"
2159− $ \dir -> do
2160− liftIO $
2161− writeFileUTF8
2162− (dir </> "hie.yaml")
2163− "cradle: {direct: {arguments: []}}"
2164− -- Open without OverloadedStrings and expect an error.
2165− doc <- createDoc "Foo.hs" "haskell" fooContent
2166− expectDiagnostics
2167− [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168− -- Update hie.yaml to enable OverloadedStrings.
2169− liftIO $
2170− writeFileUTF8
2171− (dir </> "hie.yaml")
2172− "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173− -- Send change event.
2174− let change =
2175− TextDocumentContentChangeEvent
2176− { _range = Just (Range (Position 4 0) (Position 4 0)),
2177− _rangeLength = Nothing,
2178− _text = "\n"
2179− }
2180− changeDoc doc [change]
2181− -- Now no errors.
2182− expectDiagnostics [("Foo.hs", [])]
2183− where
2184− fooContent =
2185− T.unlines
2186− [ "module Foo where",
2187− "import Data.Text",
2188− "foo :: Text",
2189− "foo = \"hello\""
2190− ]
2191184
2192185
2193186----------------------------------------------------------------------
@@ -2195,16 +188,8 @@ sessionDepsArePickedUp = testSession'
2195188
2196189
2197190testSession :: String -> Session () -> TestTree
2198−testSession name = testCase name . run
2199−
2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202−
2203−testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204−testSession' name = testCase name . run'
2205−
2206−testSessionWait :: String -> Session () -> TestTree
2207−testSessionWait name = testSession name .
191+testSession name =
192+ testCase name . run .
2208193 -- Check that any diagnostics produced were already consumed by the test case.
2209194 --
2210195 -- If in future we add test cases where we don't care about checking the diagnostics,
@@ -2213,284 +198,17 @@ testSessionWait name = testSession name .
2213198 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2214199 ( >> expectNoMoreDiagnostics 0.5)
2215200
2216−pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
2217−pickActionWithTitle title actions = do
2218− assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219− return $ head matches
2220− where
2221− titles =
2222− [ actionTitle
2223− | CACodeAction CodeAction { _title = actionTitle } <- actions
2224− ]
2225− matches =
2226− [ action
2227− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2228− , title == actionTitle
2229− ]
2230−
2231−mkRange :: Int -> Int -> Int -> Int -> Range
2232−mkRange a b c d = Range (Position a b) (Position c d)
2233201
2234202run :: Session a -> IO a
2235−run s = withTempDir $ \dir -> runInDir dir s
2236−
2237−runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238−runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239− copyTestDataFiles dir prefix
2240− runInDir dir (s dir)
2241−
2242−copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243−copyTestDataFiles dir prefix = do
2244− -- Copy all the test data files to the temporary workspace
2245− testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246− for_ testDataFiles $ \f -> do
2247− createDirectoryIfMissing True $ dir </> takeDirectory f
2248− copyFile ("test/data" </> prefix </> f) (dir </> f)
2249−
2250−run' :: (FilePath -> Session a) -> IO a
2251−run' s = withTempDir $ \dir -> runInDir dir (s dir)
2252−
2253−runInDir :: FilePath -> Session a -> IO a
2254−runInDir dir s = do
203+run s = withTempDir $ \dir -> do
2255204 ghcideExe <- locateGhcideExecutable
2256−
2257− -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2258− -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2259− createDirectoryIfMissing True $ dir ++ "/Data"
2260−
2261−
2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
205+ let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2263206 -- HIE calls getXgdDirectory which assumes that HOME is set.
2264207 -- Only sets HOME if it wasn't already set.
2265208 setEnv "HOME" "/homeless-shelter" False
2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
2267− runSessionWithConfig conf cmd lspTestCaps dir s
209+ runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2268210 where
2269211 conf = defaultConfig
2270− -- If you uncomment this you can see all logging
212+ -- If you uncomment this you can see all messages
2271213 -- which can be quite useful for debugging.
2272− -- { logStdErr = True, logColor = False }
2273− -- If you really want to, you can also see all messages
2274− -- { logMessages = True, logColor = False }
2275−
2276−openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2277−openTestDataDoc path = do
2278− source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
2280−
2281−findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282−findCodeActions doc range expectedTitles = do
2283− actions <- getCodeActions doc range
2284− let matches = sequence
2285− [ listToMaybe
2286− [ action
2287− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288− , actionTitle == expectedTitle ]
2289− | expectedTitle <- expectedTitles]
2290− let msg = show
2291− [ actionTitle
2292− | CACodeAction CodeAction { _title = actionTitle } <- actions
2293− ]
2294− ++ " is not a superset of "
2295− ++ show expectedTitles
2296− liftIO $ case matches of
2297− Nothing -> assertFailure msg
2298− Just _ -> pure ()
2299− return (fromJust matches)
2300−
2301−findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302−findCodeAction doc range t = head <$> findCodeActions doc range [t]
2303−
2304−unitTests :: TestTree
2305−unitTests = do
2306− testGroup "Unit"
2307− [ testCase "empty file path does NOT work with the empty String literal" $
2308− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309− , testCase "empty file path works using toNormalizedFilePath'" $
2310− uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311− , testCase "empty path URI" $ do
2312− Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313− uriScheme @?= "file:"
2314− uriPath @?= ""
2315− , testCase "from empty path URI" $ do
2316− let uri = Uri "file://"
2317− uriToFilePath' uri @?= Just ""
2318− ]
2319−
2320−positionMappingTests :: TestTree
2321−positionMappingTests =
2322− testGroup "position mapping"
2323− [ testGroup "toCurrent"
2324− [ testCase "before" $
2325− toCurrent
2326− (Range (Position 0 1) (Position 0 3))
2327− "ab"
2328− (Position 0 0) @?= Just (Position 0 0)
2329− , testCase "after, same line, same length" $
2330− toCurrent
2331− (Range (Position 0 1) (Position 0 3))
2332− "ab"
2333− (Position 0 3) @?= Just (Position 0 3)
2334− , testCase "after, same line, increased length" $
2335− toCurrent
2336− (Range (Position 0 1) (Position 0 3))
2337− "abc"
2338− (Position 0 3) @?= Just (Position 0 4)
2339− , testCase "after, same line, decreased length" $
2340− toCurrent
2341− (Range (Position 0 1) (Position 0 3))
2342− "a"
2343− (Position 0 3) @?= Just (Position 0 2)
2344− , testCase "after, next line, no newline" $
2345− toCurrent
2346− (Range (Position 0 1) (Position 0 3))
2347− "abc"
2348− (Position 1 3) @?= Just (Position 1 3)
2349− , testCase "after, next line, newline" $
2350− toCurrent
2351− (Range (Position 0 1) (Position 0 3))
2352− "abc\ndef"
2353− (Position 1 0) @?= Just (Position 2 0)
2354− , testCase "after, same line, newline" $
2355− toCurrent
2356− (Range (Position 0 1) (Position 0 3))
2357− "abc\nd"
2358− (Position 0 4) @?= Just (Position 1 2)
2359− , testCase "after, same line, newline + newline at end" $
2360− toCurrent
2361− (Range (Position 0 1) (Position 0 3))
2362− "abc\nd\n"
2363− (Position 0 4) @?= Just (Position 2 1)
2364− , testCase "after, same line, newline + newline at end" $
2365− toCurrent
2366− (Range (Position 0 1) (Position 0 1))
2367− "abc"
2368− (Position 0 1) @?= Just (Position 0 4)
2369− ]
2370− , testGroup "fromCurrent"
2371− [ testCase "before" $
2372− fromCurrent
2373− (Range (Position 0 1) (Position 0 3))
2374− "ab"
2375− (Position 0 0) @?= Just (Position 0 0)
2376− , testCase "after, same line, same length" $
2377− fromCurrent
2378− (Range (Position 0 1) (Position 0 3))
2379− "ab"
2380− (Position 0 3) @?= Just (Position 0 3)
2381− , testCase "after, same line, increased length" $
2382− fromCurrent
2383− (Range (Position 0 1) (Position 0 3))
2384− "abc"
2385− (Position 0 4) @?= Just (Position 0 3)
2386− , testCase "after, same line, decreased length" $
2387− fromCurrent
2388− (Range (Position 0 1) (Position 0 3))
2389− "a"
2390− (Position 0 2) @?= Just (Position 0 3)
2391− , testCase "after, next line, no newline" $
2392− fromCurrent
2393− (Range (Position 0 1) (Position 0 3))
2394− "abc"
2395− (Position 1 3) @?= Just (Position 1 3)
2396− , testCase "after, next line, newline" $
2397− fromCurrent
2398− (Range (Position 0 1) (Position 0 3))
2399− "abc\ndef"
2400− (Position 2 0) @?= Just (Position 1 0)
2401− , testCase "after, same line, newline" $
2402− fromCurrent
2403− (Range (Position 0 1) (Position 0 3))
2404− "abc\nd"
2405− (Position 1 2) @?= Just (Position 0 4)
2406− , testCase "after, same line, newline + newline at end" $
2407− fromCurrent
2408− (Range (Position 0 1) (Position 0 3))
2409− "abc\nd\n"
2410− (Position 2 1) @?= Just (Position 0 4)
2411− , testCase "after, same line, newline + newline at end" $
2412− fromCurrent
2413− (Range (Position 0 1) (Position 0 1))
2414− "abc"
2415− (Position 0 4) @?= Just (Position 0 1)
2416− ]
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.
2423− let gen = do
2424− rope <- genRope
2425− range <- genRange rope
2426− PrintableText replacement <- arbitrary
2427− oldPos <- genPosition rope
2428− pure (range, replacement, oldPos)
2429− forAll
2430− (suchThatMap gen
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
2435− let gen = do
2436− rope <- genRope
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)
2442− forAll
2443− (suchThatMap gen
2444− (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445− \(range, replacement, newPos, oldPos) ->
2446− toCurrent range replacement oldPos === Just newPos
2447− ]
2448− ]
2449−
2450−newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2451− deriving Show
2452−
2453−instance Arbitrary PrintableText where
2454− arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2455−
2456−
2457−genRope :: Gen Rope
2458−genRope = Rope.fromText . getPrintableText <$> arbitrary
2459−
2460−genPosition :: Rope -> Gen Position
2461−genPosition r = do
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
2467−
2468−genRange :: Rope -> Gen Range
2469−genRange r = do
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)
2474− endColumn <-
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
2480−
2481−-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482−nthLine :: Int -> Rope -> Rope
2483−nthLine i r
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
2488−
2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490−getWatchedFilesSubscriptionsUntil = do
2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2492− return
2493− [ args
2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2496− ]
214+ -- { logMessages = True, logColor = False, logStdErr = True }