@@ -1,158 +1,43 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE DuplicateRecordFields #-}
4{-# LANGUAGE DuplicateRecordFields #-}
6−{-# LANGUAGE PatternSynonyms #-}
7{-# LANGUAGE CPP #-}
5{-# LANGUAGE CPP #-}
8#include "ghc-api-version.h"
6#include "ghc-api-version.h"
10module Main (main) where
8module Main (main) where
12−import Control.Applicative.Combinators
10+import Control.Monad (void)
13−import Control.Exception (bracket, catch)
14−import qualified Control.Lens as Lens
16import Control.Monad.IO.Class (liftIO)
11import Control.Monad.IO.Class (liftIO)
17−import Data.Aeson (FromJSON, Value)
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
24import qualified Data.Text as T
12import qualified Data.Text as T
26−import Development.IDE.Spans.Common
27import Development.IDE.Test
13import Development.IDE.Test
28import Development.IDE.Test.Runfiles
14import Development.IDE.Test.Runfiles
29−import Development.IDE.Types.Location
30−import Development.Shake (getDirectoryFilesIO)
31import Language.Haskell.LSP.Test
15import Language.Haskell.LSP.Test
32−import Language.Haskell.LSP.Messages
33import Language.Haskell.LSP.Types
16import Language.Haskell.LSP.Types
34import Language.Haskell.LSP.Types.Capabilities
17import 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)
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
18+import System.Environment.Blank (setEnv)
39−import System.FilePath
40import System.IO.Extra
19import System.IO.Extra
41−import System.Directory
42−import Test.QuickCheck
43−import Test.QuickCheck.Instances ()
44import Test.Tasty
20import Test.Tasty
45−import Test.Tasty.ExpectedFailure
46−import Test.Tasty.Ingredients.Rerun
47import Test.Tasty.HUnit
21import Test.Tasty.HUnit
48−import Test.Tasty.QuickCheck
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)
61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
62− , initializeResponseTests
69− , findDefinitionAndHoverTests
76− , positionMappingTests
82−initializeResponseTests :: TestTree
83−initializeResponseTests = withResource acquire release tests where
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
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})}))
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
131− che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132− che title getActual _expected = testCase title doTest
135− ir <- getInitializeResponse
136− let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137− True @=? T.isSuffixOf "typesignature.add" command
140− innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
142− innerCaps _ = error "this test only expects inner capabilities"
144− acquire :: IO InitializeResponse
145− acquire = run initializeResponse
147− release :: InitializeResponse -> IO ()
24+main :: IO ()
148− release = const $ pure ()
25+main = defaultMain $ testGroup "HIE"
26+ [ testSession "open close" $ do
27+ doc <- openDoc' "Testing.hs" "haskell" ""
28+ void (message :: Session ProgressStartNotification)
30+ void (message :: Session ProgressDoneNotification)
151diagnosticTests :: TestTree
36diagnosticTests :: TestTree
152diagnosticTests = testGroup "diagnostics"
37diagnosticTests = testGroup "diagnostics"
153− [ testSessionWait "fix syntax error" $ do
38+ [ testSession "fix syntax error" $ do
154 let content = T.unlines [ "module Testing wher" ]
39 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
40+ doc <- openDoc' "Testing.hs" "haskell" content
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
41 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
157 let change = TextDocumentContentChangeEvent
42 let change = TextDocumentContentChangeEvent
158 { _range = Just (Range (Position 0 15) (Position 0 19))
43 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -161,11 +46,10 @@ diagnosticTests = testGroup "diagnostics"
162 changeDoc doc [change]
47 changeDoc doc [change]
163 expectDiagnostics [("Testing.hs", [])]
48 expectDiagnostics [("Testing.hs", [])]
164− , testSessionWait "introduce syntax error" $ do
49+ , testSession "introduce syntax error" $ do
165 let content = T.unlines [ "module Testing where" ]
50 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
51+ doc <- openDoc' "Testing.hs" "haskell" content
167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
52+ void (message :: Session ProgressStartNotification)
168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
169 let change = TextDocumentContentChangeEvent
53 let change = TextDocumentContentChangeEvent
170 { _range = Just (Range (Position 0 15) (Position 0 18))
54 { _range = Just (Range (Position 0 15) (Position 0 18))
171 , _rangeLength = Nothing
55 , _rangeLength = Nothing
@@ -173,7 +57,7 @@ diagnosticTests = testGroup "diagnostics"
174 changeDoc doc [change]
58 changeDoc doc [change]
175 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
59 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
176− , testSessionWait "variable not in scope" $ do
60+ , testSession "variable not in scope" $ do
177 let content = T.unlines
61 let content = T.unlines
178 [ "module Testing where"
62 [ "module Testing where"
179 , "foo :: Int -> Int -> Int"
63 , "foo :: Int -> Int -> Int"
@@ -181,7 +65,7 @@ diagnosticTests = testGroup "diagnostics"
181 , "bar :: Int -> Int -> Int"
65 , "bar :: Int -> Int -> Int"
182 , "bar a b = cd + b"
66 , "bar a b = cd + b"
184− _ <- createDoc "Testing.hs" "haskell" content
68+ _ <- openDoc' "Testing.hs" "haskell" content
185 expectDiagnostics
69 expectDiagnostics
186 [ ( "Testing.hs"
70 [ ( "Testing.hs"
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
71 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -189,63 +73,26 @@ diagnosticTests = testGroup "diagnostics"
192− , testSessionWait "type error" $ do
76+ , testSession "type error" $ do
193 let content = T.unlines
77 let content = T.unlines
194 [ "module Testing where"
78 [ "module Testing where"
195 , "foo :: Int -> String -> Int"
79 , "foo :: Int -> String -> Int"
196 , "foo a b = a + b"
80 , "foo a b = a + b"
198− _ <- createDoc "Testing.hs" "haskell" content
82+ _ <- openDoc' "Testing.hs" "haskell" content
199 expectDiagnostics
83 expectDiagnostics
200 [ ( "Testing.hs"
84 [ ( "Testing.hs"
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
85 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
204− , testSessionWait "typed hole" $ do
205− let content = T.unlines
206− [ "module Testing where"
207− , "foo :: Int -> String"
210− _ <- createDoc "Testing.hs" "haskell" content
213− , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
217− , testGroup "deferral" $
218− let sourceA a = T.unlines
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
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"
241− , testSessionWait "remove required module" $ do
88+ , testSession "remove required module" $ do
242 let contentA = T.unlines [ "module ModuleA where" ]
89 let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
90+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
244 let contentB = T.unlines
91 let contentB = T.unlines
245 [ "module ModuleB where"
92 [ "module ModuleB where"
246 , "import ModuleA"
93 , "import ModuleA"
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
95+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
249 let change = TextDocumentContentChangeEvent
96 let change = TextDocumentContentChangeEvent
250 { _range = Just (Range (Position 0 0) (Position 0 20))
97 { _range = Just (Range (Position 0 0) (Position 0 20))
251 , _rangeLength = Nothing
98 , _rangeLength = Nothing
@@ -253,27 +100,17 @@ diagnosticTests = testGroup "diagnostics"
254 changeDoc docA [change]
101 changeDoc docA [change]
255 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
102 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
256− , testSessionWait "add missing module" $ do
103+ , testSession "add missing module" $ do
257 let contentB = T.unlines
104 let contentB = T.unlines
258 [ "module ModuleB where"
105 [ "module ModuleB where"
259 , "import ModuleA"
106 , "import ModuleA"
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
108+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
109 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263 let contentA = T.unlines [ "module ModuleA where" ]
110 let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
111+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
265 expectDiagnostics [("ModuleB.hs", [])]
112 expectDiagnostics [("ModuleB.hs", [])]
266− , testSessionWait "add missing module (non workspace)" $ do
267− let contentB = T.unlines
268− [ "module ModuleB where"
271− _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272− expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273− let contentA = T.unlines [ "module ModuleA where" ]
274− _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275− expectDiagnostics [("/tmp/ModuleB.hs", [])]
276− , testSessionWait "cyclic module dependency" $ do
113+ , testSession "cyclic module dependency" $ do
277 let contentA = T.unlines
114 let contentA = T.unlines
278 [ "module ModuleA where"
115 [ "module ModuleA where"
279 , "import ModuleB"
116 , "import ModuleB"
@@ -282,8 +119,8 @@ diagnosticTests = testGroup "diagnostics"
282 [ "module ModuleB where"
119 [ "module ModuleB where"
283 , "import ModuleA"
120 , "import ModuleA"
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
122+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
123+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
287 expectDiagnostics
124 expectDiagnostics
288 [ ( "ModuleA.hs"
125 [ ( "ModuleA.hs"
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
126 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -292,7 +129,7 @@ diagnosticTests = testGroup "diagnostics"
292 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
129 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
295− , testSessionWait "cyclic module dependency with hs-boot" $ do
132+ , testSession "cyclic module dependency with hs-boot" $ do
296 let contentA = T.unlines
133 let contentA = T.unlines
297 [ "module ModuleA where"
134 [ "module ModuleA where"
298 , "import {-# SOURCE #-} ModuleB"
135 , "import {-# SOURCE #-} ModuleB"
@@ -304,11 +141,11 @@ diagnosticTests = testGroup "diagnostics"
304 let contentBboot = T.unlines
141 let contentBboot = T.unlines
305 [ "module ModuleB where"
142 [ "module ModuleB where"
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
144+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
145+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
146+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
310 expectDiagnostics []
147 expectDiagnostics []
311− , testSessionWait "correct reference used with hs-boot" $ do
148+ , testSession "correct reference used with hs-boot" $ do
312 let contentB = T.unlines
149 let contentB = T.unlines
313 [ "module ModuleB where"
150 [ "module ModuleB where"
314 , "import {-# SOURCE #-} ModuleA"
151 , "import {-# SOURCE #-} ModuleA"
@@ -328,29 +165,28 @@ diagnosticTests = testGroup "diagnostics"
328 -- resolved to the hs-boot file
165 -- resolved to the hs-boot file
329 , "y = x"
166 , "y = x"
331− _ <- createDoc "ModuleB.hs" "haskell" contentB
168+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
332− _ <- createDoc "ModuleA.hs" "haskell" contentA
169+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
333− _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
170+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
334− _ <- createDoc "ModuleC.hs" "haskell" contentC
171+ _ <- openDoc' "ModuleC.hs" "haskell" contentC
335 expectDiagnostics []
172 expectDiagnostics []
336− , testSessionWait "redundant import" $ do
173+ , testSession "redundant import" $ do
337 let contentA = T.unlines ["module ModuleA where"]
174 let contentA = T.unlines ["module ModuleA where"]
338 let contentB = T.unlines
175 let contentB = T.unlines
339 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
176 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
340 , "module ModuleB where"
177 , "module ModuleB where"
341 , "import ModuleA"
178 , "import ModuleA"
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
180+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
181+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
345 expectDiagnostics
182 expectDiagnostics
346 [ ( "ModuleB.hs"
183 [ ( "ModuleB.hs"
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
184 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
350− , testSessionWait "package imports" $ do
187+ , testSession "package imports" $ do
351 let thisDataListContent = T.unlines
188 let thisDataListContent = T.unlines
352 [ "module Data.List where"
189 [ "module Data.List where"
354 , "x = 123"
190 , "x = 123"
356 let mainContent = T.unlines
192 let mainContent = T.unlines
@@ -363,8 +199,8 @@ diagnosticTests = testGroup "diagnostics"
363 , "wrong1 = ThisList.map"
199 , "wrong1 = ThisList.map"
364 , "wrong2 = BaseList.x"
200 , "wrong2 = BaseList.x"
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
202+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
203+ _ <- openDoc' "Main.hs" "haskell" mainContent
368 expectDiagnostics
204 expectDiagnostics
369 [ ( "Main.hs"
205 [ ( "Main.hs"
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
206 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -372,14 +208,14 @@ diagnosticTests = testGroup "diagnostics"
375− , testSessionWait "unqualified warnings" $ do
211+ , testSession "unqualified warnings" $ do
376 let fooContent = T.unlines
212 let fooContent = T.unlines
377 [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
213 [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
378 , "module Foo where"
214 , "module Foo where"
379 , "foo :: Ord a => a -> Int"
215 , "foo :: Ord a => a -> Int"
380 , "foo a = 1"
216 , "foo a = 1"
382− _ <- createDoc "Foo.hs" "haskell" fooContent
218+ _ <- openDoc' "Foo.hs" "haskell" fooContent
383 expectDiagnostics
219 expectDiagnostics
384 [ ( "Foo.hs"
220 [ ( "Foo.hs"
385 -- The test is to make sure that warnings contain unqualified names
221 -- The test is to make sure that warnings contain unqualified names
@@ -390,72 +226,6 @@ diagnosticTests = testGroup "diagnostics"
393− , testSessionWait "lower-case drive" $ do
394− let aContent = T.unlines
395− [ "module A.A where"
398− bContent = T.unlines
399− [ "{-# OPTIONS_GHC -Wall #-}"
400− , "module A.B where"
401− , "import Data.List"
403− uriB <- getDocUri "A/B.hs"
404− Just pathB <- pure $ uriToFilePath uriB
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
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)
427− , testSessionWait "haddock parse error" $ do
428− let fooContent = T.unlines
429− [ "module Foo where"
433− _ <- createDoc "Foo.hs" "haskell" fooContent
436− , [(DsError, (2, 8), "Parse error on input")
440− , testSessionWait "strip file path" $ do
444− [ "module " <> name <> " where"
445− , "value :: Maybe ()"
448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449− notification <- skipManyTill anyMessage diagnostic
456− Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457− failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458− Lens.mapMOf_ offenders failure notification
461codeActionTests :: TestTree
231codeActionTests :: TestTree
@@ -463,46 +233,8 @@ codeActionTests = testGroup "code actions"
463 [ renameActionTests
233 [ renameActionTests
464 , typeWildCardActionTests
234 , typeWildCardActionTests
465 , removeImportTests
235 , removeImportTests
467− , suggestImportTests
469− , fixConstructorImportTests
470 , importRenameActionTests
236 , importRenameActionTests
471 , fillTypedHoleTests
237 , fillTypedHoleTests
473− , insertNewDefinitionTests
476−codeLensesTests :: TestTree
477−codeLensesTests = testGroup "code lenses"
481−watchedFilesTests :: TestTree
482−watchedFilesTests = testGroup "watched files"
483− [ testSession' "workspace files" $ \sessionDir -> do
484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
488− -- Expect 4 subscriptions (A does not get any because it's VFS):
489− -- - /path-to-workspace/WatchedFilesMissingModule.hs
490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493− liftIO $ length watchedFileRegs @?= 4
495− , testSession' "non workspace file" $ \sessionDir -> do
496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501− -- - /path-to-workspace/WatchedFilesMissingModule.hs
502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503− liftIO $ length watchedFileRegs @?= 2
505− -- TODO add a test for didChangeWorkspaceFolder
508renameActionTests :: TestTree
240renameActionTests :: TestTree
@@ -513,9 +245,11 @@ renameActionTests = testGroup "rename actions"
513 , "foo :: Int -> Int"
245 , "foo :: Int -> Int"
514 , "foo argName = argNme"
246 , "foo argName = argNme"
516− doc <- createDoc "Testing.hs" "haskell" content
248+ doc <- openDoc' "Testing.hs" "haskell" content
517 _ <- waitForDiagnostics
249 _ <- waitForDiagnostics
250+ [CACodeAction action@CodeAction { _title = actionTitle }]
518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
251+ <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
252+ liftIO $ "Replace with ‘argName’" @=? actionTitle
519 executeCodeAction action
253 executeCodeAction action
520 contentAfterAction <- documentContents doc
254 contentAfterAction <- documentContents doc
521 let expectedContentAfterAction = T.unlines
255 let expectedContentAfterAction = T.unlines
@@ -531,9 +265,11 @@ renameActionTests = testGroup "rename actions"
531 , "foo :: Maybe a -> [a]"
265 , "foo :: Maybe a -> [a]"
532 , "foo = maybToList"
266 , "foo = maybToList"
534− doc <- createDoc "Testing.hs" "haskell" content
268+ doc <- openDoc' "Testing.hs" "haskell" content
535 _ <- waitForDiagnostics
269 _ <- waitForDiagnostics
270+ [CACodeAction action@CodeAction { _title = actionTitle }]
536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
271+ <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
272+ liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
537 executeCodeAction action
273 executeCodeAction action
538 contentAfterAction <- documentContents doc
274 contentAfterAction <- documentContents doc
539 let expectedContentAfterAction = T.unlines
275 let expectedContentAfterAction = T.unlines
@@ -549,11 +285,12 @@ renameActionTests = testGroup "rename actions"
549 , "foo :: Char -> Char -> Char -> Char"
285 , "foo :: Char -> Char -> Char -> Char"
550 , "foo argument1 argument2 argument3 = argumentX"
286 , "foo argument1 argument2 argument3 = argumentX"
552− doc <- createDoc "Testing.hs" "haskell" content
288+ doc <- openDoc' "Testing.hs" "haskell" content
553 _ <- waitForDiagnostics
289 _ <- waitForDiagnostics
554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
290+ actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
291+ let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
292+ expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
556− return()
293+ liftIO $ expectedActionTitles @=? actionTitles
557 , testSession "change infix function" $ do
294 , testSession "change infix function" $ do
558 let content = T.unlines
295 let content = T.unlines
559 [ "module Testing where"
296 [ "module Testing where"
@@ -561,7 +298,7 @@ renameActionTests = testGroup "rename actions"
561 , "monus x y = max 0 (x - y)"
298 , "monus x y = max 0 (x - y)"
562 , "foo x y = x `monnus` y"
299 , "foo x y = x `monnus` y"
564− doc <- createDoc "Testing.hs" "haskell" content
301+ doc <- openDoc' "Testing.hs" "haskell" content
565 _ <- waitForDiagnostics
302 _ <- waitForDiagnostics
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
303 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
304 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -584,7 +321,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
584 , "func :: _"
321 , "func :: _"
585 , "func x = x"
322 , "func x = x"
587− doc <- createDoc "Testing.hs" "haskell" content
324+ doc <- openDoc' "Testing.hs" "haskell" content
588 _ <- waitForDiagnostics
325 _ <- waitForDiagnostics
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
326 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
327 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -604,7 +341,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
604 , "func :: _"
341 , "func :: _"
605 , "func x y = x + y"
342 , "func x y = x + y"
607− doc <- createDoc "Testing.hs" "haskell" content
344+ doc <- openDoc' "Testing.hs" "haskell" content
608 _ <- waitForDiagnostics
345 _ <- waitForDiagnostics
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
346 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
347 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -627,7 +364,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
627 , " y = x * 2"
364 , " y = x * 2"
628 , " in y"
365 , " in y"
630− doc <- createDoc "Testing.hs" "haskell" content
367+ doc <- openDoc' "Testing.hs" "haskell" content
631 _ <- waitForDiagnostics
368 _ <- waitForDiagnostics
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
369 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
370 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -652,15 +389,14 @@ removeImportTests = testGroup "remove import actions"
652 let contentA = T.unlines
389 let contentA = T.unlines
653 [ "module ModuleA where"
390 [ "module ModuleA where"
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
392+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
656 let contentB = T.unlines
393 let contentB = T.unlines
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
394 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658 , "module ModuleB where"
395 , "module ModuleB where"
659 , "import ModuleA"
396 , "import ModuleA"
660− , "stuffB :: Integer"
661 , "stuffB = 123"
397 , "stuffB = 123"
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
399+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
664 _ <- waitForDiagnostics
400 _ <- waitForDiagnostics
665 [CACodeAction action@CodeAction { _title = actionTitle }]
401 [CACodeAction action@CodeAction { _title = actionTitle }]
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
402 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -670,7 +406,6 @@ removeImportTests = testGroup "remove import actions"
670 let expectedContentAfterAction = T.unlines
406 let expectedContentAfterAction = T.unlines
671 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
407 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
672 , "module ModuleB where"
408 , "module ModuleB where"
673− , "stuffB :: Integer"
674 , "stuffB = 123"
409 , "stuffB = 123"
676 liftIO $ expectedContentAfterAction @=? contentAfterAction
411 liftIO $ expectedContentAfterAction @=? contentAfterAction
@@ -678,15 +413,14 @@ removeImportTests = testGroup "remove import actions"
678 let contentA = T.unlines
413 let contentA = T.unlines
679 [ "module ModuleA where"
414 [ "module ModuleA where"
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
416+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
682 let contentB = T.unlines
417 let contentB = T.unlines
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
418 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684 , "module ModuleB where"
419 , "module ModuleB where"
685 , "import qualified ModuleA"
420 , "import qualified ModuleA"
686− , "stuffB :: Integer"
687 , "stuffB = 123"
421 , "stuffB = 123"
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
423+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
690 _ <- waitForDiagnostics
424 _ <- waitForDiagnostics
691 [CACodeAction action@CodeAction { _title = actionTitle }]
425 [CACodeAction action@CodeAction { _title = actionTitle }]
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
426 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -696,457 +430,10 @@ removeImportTests = testGroup "remove import actions"
696 let expectedContentAfterAction = T.unlines
430 let expectedContentAfterAction = T.unlines
697 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
431 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
698 , "module ModuleB where"
432 , "module ModuleB where"
699− , "stuffB :: Integer"
700 , "stuffB = 123"
433 , "stuffB = 123"
702 liftIO $ expectedContentAfterAction @=? contentAfterAction
435 liftIO $ expectedContentAfterAction @=? contentAfterAction
703− , testSession "redundant binding" $ do
704− let contentA = T.unlines
705− [ "module ModuleA where"
707− , "stuffB :: Integer"
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"
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"
731− liftIO $ expectedContentAfterAction @=? contentAfterAction
732− , testSession "redundant operator" $ do
733− let contentA = T.unlines
734− [ "module ModuleA where"
737− , "stuffB :: Integer"
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"
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"
760− liftIO $ expectedContentAfterAction @=? contentAfterAction
761− , testSession "redundant all import" $ do
762− let contentA = T.unlines
763− [ "module ModuleA where"
765− , "stuffB :: Integer"
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"
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"
788− liftIO $ expectedContentAfterAction @=? contentAfterAction
789− , testSession "redundant constructor import" $ do
790− let contentA = T.unlines
791− [ "module ModuleA where"
795− _docA <- createDoc "ModuleA.hs" "haskell" contentA
796− let contentB = T.unlines
797− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798− , "module ModuleB where"
799− , "import ModuleA (D(A,B), E(F))"
802− docB <- createDoc "ModuleB.hs" "haskell" contentB
803− _ <- waitForDiagnostics
804− [CACodeAction action@CodeAction { _title = actionTitle }]
805− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
806− liftIO $ "Remove A, E, F from import" @=? actionTitle
807− executeCodeAction action
808− contentAfterAction <- documentContents docB
809− let expectedContentAfterAction = T.unlines
810− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
811− , "module ModuleB where"
812− , "import ModuleA (D(B))"
815− liftIO $ expectedContentAfterAction @=? contentAfterAction
818−extendImportTests :: TestTree
819−extendImportTests = testGroup "extend import actions"
820− [ testSession "extend single line import with value" $ template
822− [ "module ModuleA where"
823− , "stuffA :: Double"
824− , "stuffA = 0.00750"
825− , "stuffB :: Integer"
829− [ "module ModuleB where"
830− , "import ModuleA as A (stuffB)"
831− , "main = print (stuffA, stuffB)"
833− (Range (Position 3 17) (Position 3 18))
834− "Add stuffA to the import list of ModuleA"
836− [ "module ModuleB where"
837− , "import ModuleA as A (stuffA, stuffB)"
838− , "main = print (stuffA, stuffB)"
840− , testSession "extend single line import with operator" $ template
842− [ "module ModuleA where"
843− , "(.*) :: Integer -> Integer -> Integer"
845− , "stuffB :: Integer"
849− [ "module ModuleB where"
850− , "import ModuleA as A (stuffB)"
851− , "main = print (stuffB .* stuffB)"
853− (Range (Position 3 17) (Position 3 18))
854− "Add .* to the import list of ModuleA"
856− [ "module ModuleB where"
857− , "import ModuleA as A ((.*), stuffB)"
858− , "main = print (stuffB .* stuffB)"
860− , testSession "extend single line import with type" $ template
862− [ "module ModuleA where"
866− [ "module ModuleB where"
867− , "import ModuleA ()"
871− (Range (Position 2 5) (Position 2 5))
872− "Add A to the import list of ModuleA"
874− [ "module ModuleB where"
875− , "import ModuleA (A)"
879− , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template
881− [ "module ModuleA where"
882− , "data A = Constructor"
885− [ "module ModuleB where"
886− , "import ModuleA (A)"
890− (Range (Position 2 5) (Position 2 5))
891− "Add Constructor to the import list of ModuleA"
893− [ "module ModuleB where"
894− , "import ModuleA (A(Constructor))"
898− , testSession "extend single line qualified import with value" $ template
900− [ "module ModuleA where"
901− , "stuffA :: Double"
902− , "stuffA = 0.00750"
903− , "stuffB :: Integer"
907− [ "module ModuleB where"
908− , "import qualified ModuleA as A (stuffB)"
909− , "main = print (A.stuffA, A.stuffB)"
911− (Range (Position 3 17) (Position 3 18))
912− "Add stuffA to the import list of ModuleA"
914− [ "module ModuleB where"
915− , "import qualified ModuleA as A (stuffA, stuffB)"
916− , "main = print (A.stuffA, A.stuffB)"
918− , testSession "extend multi line import with value" $ template
920− [ "module ModuleA where"
921− , "stuffA :: Double"
922− , "stuffA = 0.00750"
923− , "stuffB :: Integer"
927− [ "module ModuleB where"
928− , "import ModuleA (stuffB"
930− , "main = print (stuffA, stuffB)"
932− (Range (Position 3 17) (Position 3 18))
933− "Add stuffA to the import list of ModuleA"
935− [ "module ModuleB where"
936− , "import ModuleA (stuffA, stuffB"
938− , "main = print (stuffA, stuffB)"
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
954−suggestImportTests :: TestTree
955−suggestImportTests = testGroup "suggest import actions"
956− [ testGroup "Dont want suggestion"
958− test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
960− , test False [] "f = First" [] "import Data.Monoid (First)"
962− , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963− -- package not in scope
964− , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
966− , testGroup "want suggestion"
967− [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
968− , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969− , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970− , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
971− , test True [] "f = First" [] "import Data.Monoid (First(First))"
972− , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973− , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974− , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975− , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
976− , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977− , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978− , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979− , test True [] "f = (&)" [] "import Data.Function ((&))"
980− , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
981− , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982− , test True [] "f = pack" [] "import Data.Text (pack)"
983− , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984− , test True [] "f = [] & id" [] "import Data.Function ((&))"
985− , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
989− test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990− let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991− after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992− cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993− liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994− doc <- createDoc "Test.hs" "haskell" before
995− _diags <- waitForDiagnostics
996− let defLine = length imps + 1
997− range = Range (Position defLine 0) (Position defLine maxBound)
998− actions <- getCodeActions doc range
1001− action <- liftIO $ pickActionWithTitle newImp actions
1002− executeCodeAction action
1003− contentAfterAction <- documentContents doc
1004− liftIO $ after @=? contentAfterAction
1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1009−addExtensionTests :: TestTree
1010−addExtensionTests = testGroup "add language extension actions"
1011− [ testSession "add NamedFieldPuns language extension" $ template
1013− [ "module Module where"
1015− , "data A = A { getA :: Bool }"
1018− , "f A { getA } = getA"
1020− (Range (Position 0 0) (Position 0 0))
1021− "Add NamedFieldPuns extension"
1023− [ "{-# LANGUAGE NamedFieldPuns #-}"
1024− , "module Module where"
1026− , "data A = A { getA :: Bool }"
1029− , "f A { getA } = getA"
1031− , testSession "add RecordWildCards language extension" $ template
1033− [ "module Module where"
1035− , "data A = A { getA :: Bool }"
1038− , "f A { .. } = getA"
1040− (Range (Position 0 0) (Position 0 0))
1041− "Add RecordWildCards extension"
1043− [ "{-# LANGUAGE RecordWildCards #-}"
1044− , "module Module where"
1046− , "data A = A { getA :: Bool }"
1049− , "f A { .. } = getA"
1053− template initialContent range expectedAction expectedContents = do
1054− doc <- createDoc "Module.hs" "haskell" initialContent
1055− _ <- waitForDiagnostics
1056− CACodeAction action@CodeAction { _title = actionTitle } : _
1057− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058− getCodeActions doc range
1059− liftIO $ expectedAction @=? actionTitle
1060− executeCodeAction action
1061− contentAfterAction <- documentContents doc
1062− liftIO $ expectedContents @=? contentAfterAction
1065−insertNewDefinitionTests :: TestTree
1066−insertNewDefinitionTests = testGroup "insert new definition actions"
1067− [ testSession "insert new function definition" $ do
1069− ["foo True = select [True]"
1071− ,"foo False = False"
1075− ,"someOtherCode = ()"
1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1078− _ <- waitForDiagnostics
1079− CACodeAction action@CodeAction { _title = actionTitle } : _
1080− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1081− getCodeActions docB (R 1 0 1 50)
1082− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1083− executeCodeAction action
1084− contentAfterAction <- documentContents docB
1085− liftIO $ contentAfterAction @?= T.unlines (txtB ++
1087− , "select :: [Bool] -> Bool"
1088− , "select = error \"not implemented\""
1091− , testSession "define a hole" $ do
1093− ["foo True = _select [True]"
1095− ,"foo False = False"
1099− ,"someOtherCode = ()"
1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1102− _ <- waitForDiagnostics
1103− CACodeAction action@CodeAction { _title = actionTitle } : _
1104− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1105− getCodeActions docB (R 1 0 1 50)
1106− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1107− executeCodeAction action
1108− contentAfterAction <- documentContents docB
1109− liftIO $ contentAfterAction @?= T.unlines (
1110− ["foo True = select [True]"
1112− ,"foo False = False"
1114− , "select :: [Bool] -> Bool"
1115− , "select = error \"not implemented\""
1120−fixConstructorImportTests :: TestTree
1121−fixConstructorImportTests = testGroup "fix import actions"
1122− [ testSession "fix constructor import" $ template
1124− [ "module ModuleA where"
1125− , "data A = Constructor"
1128− [ "module ModuleB where"
1129− , "import ModuleA(Constructor)"
1131− (Range (Position 1 10) (Position 1 11))
1132− "Fix import of A(Constructor)"
1134− [ "module ModuleB where"
1135− , "import ModuleA(A(Constructor))"
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
1151importRenameActionTests :: TestTree
438importRenameActionTests :: TestTree
1152importRenameActionTests = testGroup "import rename actions"
439importRenameActionTests = testGroup "import rename actions"
@@ -1157,7 +444,7 @@ importRenameActionTests = testGroup "import rename actions"
1157 [ "module Testing where"
444 [ "module Testing where"
1158 , "import Data.Mape"
445 , "import Data.Mape"
1160− doc <- createDoc "Testing.hs" "haskell" content
447+ doc <- openDoc' "Testing.hs" "haskell" content
1161 _ <- waitForDiagnostics
448 _ <- waitForDiagnostics
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
449 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 ]
450 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1191,16 +478,22 @@ fillTypedHoleTests = let
1191 check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
478 check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
1192 check actionTitle
479 check actionTitle
1193 oldA oldB oldC
480 oldA oldB oldC
1194− newA newB newC = testSession (T.unpack actionTitle) $ do
481+ newA newB newC = testSession (T.unpack actionTitle) $ do
1195 let originalCode = sourceCode oldA oldB oldC
482 let originalCode = sourceCode oldA oldB oldC
1196 let expectedCode = sourceCode newA newB newC
483 let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
484+ doc <- openDoc' "Testing.hs" "haskell" originalCode
1198 _ <- waitForDiagnostics
485 _ <- waitForDiagnostics
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
486 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
487+ let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1201 executeCodeAction chosenAction
488 executeCodeAction chosenAction
1202 modifiedCode <- documentContents doc
489 modifiedCode <- documentContents doc
1203 liftIO $ expectedCode @=? modifiedCode
490 liftIO $ expectedCode @=? modifiedCode
492+ pickActionWithTitle title actions = head
494+ | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
495+ , title == actionTitle ]
1205 testGroup "fill typed holes"
498 testGroup "fill typed holes"
1206 [ check "replace hole `_` with show"
499 [ check "replace hole `_` with show"
@@ -1232,979 +525,13 @@ fillTypedHoleTests = let
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]
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
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"
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]
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
1280− modifiedCode <- getDocumentEdit doc
1281− liftIO $ expectedCode @=? modifiedCode
1283− testGroup "add signature"
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"
1293− | (title, enableWarnings) <-
1294− [("with warnings enabled", True)
1295− ,("with warnings disabled", False)
1299−checkDefs :: [Location] -> Session [Expect] -> Session ()
1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
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
1313− assertNDefinitionsFound :: Int -> [a] -> Session ()
1314− assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1316− assertRangeCorrect Location{_range = foundRange} expectedRange =
1317− liftIO $ expectedRange @=? foundRange
1320−findDefinitionAndHoverTests :: TestTree
1321−findDefinitionAndHoverTests = let
1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324− doc <- openTestDataDoc (dir </> sourceFilePath)
1325− found <- get doc pos
1326− check found targetRange
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
1336− Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1337− ,_range = rangeInHover } ->
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
1346− extractLineColFromHoverMsg :: T.Text -> [T.Text]
1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
1349− checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1350− checkHoverRange expectedRange rangeInHover msg =
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}
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)
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)
1369− sourceFilePath = T.unpack sourceFileName
1370− sourceFileName = "GotoHover.hs"
1372− mkFindTests tests = testGroup "get"
1373− [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
1375− , checkFileCompiles sourceFilePath ]
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
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
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]
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)"
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
1470−checkFileCompiles :: FilePath -> TestTree
1471−checkFileCompiles fp =
1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473− void (openTestDataDoc (dir </> fp))
1474− expectNoMoreDiagnostics 0.5
1478−pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
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"
1494− _ <- createDoc "Testing.hs" "haskell" content
1497− [(DsError, (8, 14), "Variable not in scope: c")]
1501−cppTests :: TestTree
1504− [ testCase "cpp-error" $ do
1507− [ "{-# LANGUAGE CPP #-}",
1508− "module Testing where",
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
1515− (run $ expectError content (2, -1))
1517− let _ = e :: HUnitFailure
1518− run $ expectError content (2, 1)
1520− , testSessionWait "cpp-ghcide" $ do
1521− _ <- createDoc "A.hs" "haskell" $ T.unlines
1522− ["{-# LANGUAGE CPP #-}"
1524− ,"#ifdef __GHCIDE__"
1530− expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1533− expectError :: T.Text -> Cursor -> Session ()
1534− expectError content cursor = do
1535− _ <- createDoc "Testing.hs" "haskell" content
1538− [(DsError, cursor, "error: unterminated")]
1541− expectNoMoreDiagnostics 0.5
1543−preprocessorTests :: TestTree
1544−preprocessorTests = testSessionWait "preprocessor" $ do
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
1551− _ <- createDoc "Testing.hs" "haskell" content
1554− [(DsError, (2, 8), "Variable not in scope: z")]
1559−safeTests :: TestTree
1563− [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564− testSessionWait "load" $ do
1567− ["{-# LANGUAGE Trustworthy #-}"
1569− ,"import System.IO.Unsafe"
1570− ,"import System.IO"
1571− ,"trustWorthyId :: a -> a"
1572− ,"trustWorthyId i = unsafePerformIO $ do"
1573− ," putStrLn \"I'm safe\""
1577− ["{-# LANGUAGE Safe #-}"
1580− ,"safeId :: a -> a"
1581− ,"safeId = trustWorthyId"
1584− _ <- createDoc "A.hs" "haskell" sourceA
1585− _ <- createDoc "B.hs" "haskell" sourceB
1586− expectNoMoreDiagnostics 1 ]
1592− [ -- Test for https://github.com/digital-asset/ghcide/pull/212
1593− testSessionWait "load" $ do
1596− [ "{-# LANGUAGE PackageImports #-}",
1597− "{-# LANGUAGE TemplateHaskell #-}",
1599− "import \"template-haskell\" Language.Haskell.TH",
1601− "a = $(litE $ IntegerL 3)"
1605− [ "{-# LANGUAGE PackageImports #-}",
1606− "{-# LANGUAGE TemplateHaskell #-}",
1609− "import \"template-haskell\" Language.Haskell.TH",
1611− "b = $(litE $ IntegerL $ a) + n"
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
1619− [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620− ,"{-# LANGUAGE TemplateHaskell #-}"
1621− ,"module A (a) where"
1622− ,"import Data.Data"
1623− ,"import Language.Haskell.TH"
1624− ,"newtype A = A () deriving (Data)"
1629− [ "{-# LANGUAGE TemplateHaskell #-}"
1634− _ <- createDoc "A.hs" "haskell" sourceA
1635− _ <- createDoc "B.hs" "haskell" sourceB
1639−completionTests :: TestTree
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"
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")
1663− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
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"
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"
1697− , testSessionWait "keyword" $ do
1698− let source = T.unlines ["module A where", "f = newty"]
1699− docId <- createDoc "A.hs" "haskell" source
1700− compls <- getCompletions docId (Position 1 9)
1701− liftIO $ compls @?= [keywordItem "newtype"]
1702− , testSessionWait "type context" $ do
1703− let source = T.unlines
1704− [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705− , "module A () where"
1708− docId <- createDoc "A.hs" "haskell" source
1709− expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1711− [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712− [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713− , "module A () where"
1718− -- At this point the module parses but does not typecheck.
1719− -- This should be sufficient to detect that we are in a
1720− -- type context and only show the completion to the type.
1721− compls <- getCompletions docId (Position 3 11)
1722− liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1725− dropDocs :: CompletionItem -> CompletionItem
1726− dropDocs ci = ci { _documentation = Nothing }
1727− complItem label kind ty = CompletionItem
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
1745− keywordItem label = CompletionItem
1747− , _kind = Just CiKeyword
1749− , _detail = Nothing
1750− , _documentation = Nothing
1751− , _deprecated = Nothing
1752− , _preselect = Nothing
1753− , _sortText = Nothing
1754− , _filterText = Nothing
1755− , _insertText = Nothing
1756− , _insertTextFormat = Nothing
1757− , _textEdit = Nothing
1758− , _additionalTextEdits = Nothing
1759− , _commitCharacters = Nothing
1760− , _command = Nothing
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
1771−outlineTests :: TestTree
1772−outlineTests = testGroup
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
1782− [ classSymbol "A a"
1784− [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
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)
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 () = ()"
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)
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 ()"
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)
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"
1866− [docSymbol "C" SkConstructor (R 0 9 0 10)]
1868− , testSessionWait "record fields" $ do
1869− let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870− docId <- createDoc "A.hs" "haskell" source
1871− symbols <- getDocumentSymbols docId
1872− liftIO $ symbols @=? Left
1873− [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874− [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875− [ docSymbol "x" SkField (R 1 2 1 3)
1876− , docSymbol "y" SkField (R 2 4 2 5)
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"
1888− [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1891− , testSessionWait "multiple import" $ do
1892− let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893− docId <- createDoc "A.hs" "haskell" source
1894− symbols <- getDocumentSymbols docId
1895− liftIO $ symbols @?= Left
1896− [docSymbolWithChildren "imports"
1899− [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900− , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1903− , testSessionWait "foreign import" $ do
1904− let source = T.unlines
1905− [ "{-# language ForeignFunctionInterface #-}"
1906− , "foreign import ccall \"a\" a :: Int"
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"
1916− docId <- createDoc "A.hs" "haskell" source
1917− symbols <- getDocumentSymbols docId
1918− liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
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
1938− classSymbol name loc cc = DocumentSymbol name
1946−pattern R :: Int -> Int -> Int -> Int -> Range
1947−pattern R x y x' y' = Range (Position x y) (Position x' y')
1949−xfail :: TestTree -> String -> TestTree
1950−xfail = flip expectFailBecause
1952−xfail8101 :: TestTree -> String -> TestTree
1953−#if MIN_GHC_API_VERSION(8,10,0)
1954−xfail8101 = flip expectFailBecause
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
1968−-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1971−mkR :: Int -> Int -> Int -> Int -> Expect
1972−mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1977−haddockTests :: TestTree
1979− = testGroup "haddock"
1980− [ testCase "Num" $ checkHaddock
1982− [ "However, '(+)' and '(*)' are"
1983− , "customarily expected to define a ring and have the following properties:"
1985− , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986− , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987− , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1993− , "However, `(+)` and `(*)` are"
1994− , "customarily expected to define a ring and have the following properties: "
1995− , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996− , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997− , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
2000− , testCase "unsafePerformIO" $ checkHaddock
2003− , "different precautions:"
2005− , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006− , " that calls 'unsafePerformIO'. If the call is inlined,"
2007− , " the I\\/O may be performed more than once."
2009− , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010− , " elimination being performed on the module."
2018− , "different precautions: "
2019− , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020− , " that calls `unsafePerformIO` . If the call is inlined,"
2021− , " the I/O may be performed more than once."
2023− , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024− , " elimination being performed on the module."
2030− checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2032−cradleTests :: TestTree
2033−cradleTests = testGroup "cradle"
2034− [testGroup "dependencies" [sessionDepsArePickedUp]
2035− ,testGroup "loading" [loadCradleOnlyonce]
2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2039−loadCradleOnlyonce :: TestTree
2040−loadCradleOnlyonce = testGroup "load cradle only once"
2041− [ testSession' "implicit" implicit
2042− , testSession' "direct" direct
2046− liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047− "cradle: {direct: {arguments: []}}"
2049− implicit dir = test dir
2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052− msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053− liftIO $ length msgs @?= 1
2054− changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056− liftIO $ length msgs @?= 0
2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059− liftIO $ length msgs @?= 0
2062−dependentFileTest :: TestTree
2063−dependentFileTest = testGroup "addDependentFile"
2064− [testGroup "file-changed" [testSession' "test" test]
2068− -- If the file contains B then no type error
2069− -- otherwise type error
2070− liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071− let fooContent = T.unlines
2072− [ "{-# LANGUAGE TemplateHaskell #-}"
2073− , "module Foo where"
2074− , "import Language.Haskell.TH.Syntax"
2077− , " qAddDependentFile \"dep-file.txt\""
2078− , " f <- qRunIO (readFile \"dep-file.txt\")"
2079− , " if f == \"B\" then [| 1 |] else lift f)"
2081− let bazContent = T.unlines ["module Baz where", "import Foo"]
2082− _ <-createDoc "Foo.hs" "haskell" fooContent
2083− doc <- createDoc "Baz.hs" "haskell" bazContent
2085− [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086− -- Now modify the dependent file
2087− liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088− let change = TextDocumentContentChangeEvent
2089− { _range = Just (Range (Position 2 0) (Position 2 6))
2090− , _rangeLength = Nothing
2093− -- Modifying Baz will now trigger Foo to be rebuilt as well
2094− changeDoc doc [change]
2095− expectDiagnostics [("Foo.hs", [])]
2098−cradleLoadedMessage :: Session FromServerMessage
2099−cradleLoadedMessage = satisfy $ \case
2100− NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2103−cradleLoadedMethod :: T.Text
2104−cradleLoadedMethod = "ghcide/cradle/loaded"
2106−-- Stack sets this which trips up cabal in the multi-component tests.
2107−-- However, our plugin tests rely on those env vars so we unset it locally.
2108−withoutStackEnv :: IO a -> IO a
2111− (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112− (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2115− [ "GHC_PACKAGE_PATH"
2116− , "GHC_ENVIRONMENT"
2117− , "HASKELL_DIST_DIR"
2118− , "HASKELL_PACKAGE_SANDBOX"
2119− , "HASKELL_PACKAGE_SANDBOXES"
2121− restore var Nothing = unsetEnv var
2122− restore var (Just val) = setEnv var val True
2124−simpleMultiTest :: TestTree
2125−simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126− let aPath = dir </> "a/A.hs"
2127− bPath = dir </> "b/B.hs"
2128− aSource <- liftIO $ readFileUtf8 aPath
2129− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130− expectNoMoreDiagnostics 0.5
2131− bSource <- liftIO $ readFileUtf8 bPath
2132− bdoc <- createDoc bPath "haskell" bSource
2133− expectNoMoreDiagnostics 0.5
2134− locs <- getDefinitions bdoc (Position 2 7)
2135− let fooL = mkL adoc 2 0 2 3
2136− checkDefs locs (pure [fooL])
2137− expectNoMoreDiagnostics 0.5
2139−-- Like simpleMultiTest but open the files in the other order
2140−simpleMultiTest2 :: TestTree
2141−simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142− let aPath = dir </> "a/A.hs"
2143− bPath = dir </> "b/B.hs"
2144− bSource <- liftIO $ readFileUtf8 bPath
2145− bdoc <- createDoc bPath "haskell" bSource
2146− expectNoMoreDiagnostics 5
2147− aSource <- liftIO $ readFileUtf8 aPath
2148− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149− -- Need to have some delay here or the test fails
2150− expectNoMoreDiagnostics 5
2151− locs <- getDefinitions bdoc (Position 2 7)
2152− let fooL = mkL adoc 2 0 2 3
2153− checkDefs locs (pure [fooL])
2154− expectNoMoreDiagnostics 0.5
2156−sessionDepsArePickedUp :: TestTree
2157−sessionDepsArePickedUp = testSession'
2158− "session-deps-are-picked-up"
2162− (dir </> "hie.yaml")
2163− "cradle: {direct: {arguments: []}}"
2164− -- Open without OverloadedStrings and expect an error.
2165− doc <- createDoc "Foo.hs" "haskell" fooContent
2167− [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168− -- Update hie.yaml to enable OverloadedStrings.
2171− (dir </> "hie.yaml")
2172− "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173− -- Send change event.
2175− TextDocumentContentChangeEvent
2176− { _range = Just (Range (Position 4 0) (Position 4 0)),
2177− _rangeLength = Nothing,
2180− changeDoc doc [change]
2182− expectDiagnostics [("Foo.hs", [])]
2186− [ "module Foo where",
2187− "import Data.Text",
2193----------------------------------------------------------------------
528----------------------------------------------------------------------
2197testSession :: String -> Session () -> TestTree
532testSession :: String -> Session () -> TestTree
2198−testSession name = testCase name . run
533+testSession name =
2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2203−testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204−testSession' name = testCase name . run'
534+ testCase name . run .
2206−testSessionWait :: String -> Session () -> TestTree
2207−testSessionWait name = testSession name .
2208 -- Check that any diagnostics produced were already consumed by the test case.
535 -- Check that any diagnostics produced were already consumed by the test case.
2210 -- If in future we add test cases where we don't care about checking the diagnostics,
537 -- If in future we add test cases where we don't care about checking the diagnostics,
@@ -2213,284 +540,17 @@ testSessionWait name = testSession name .
2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
540 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2214 ( >> expectNoMoreDiagnostics 0.5)
541 ( >> expectNoMoreDiagnostics 0.5)
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
2223− | CACodeAction CodeAction { _title = actionTitle } <- actions
2227− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2228− , title == actionTitle
2231−mkRange :: Int -> Int -> Int -> Int -> Range
2232−mkRange a b c d = Range (Position a b) (Position c d)
2234run :: Session a -> IO a
544run :: Session a -> IO a
2235−run s = withTempDir $ \dir -> runInDir dir s
545+run s = withTempDir $ \dir -> do
2237−runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238−runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239− copyTestDataFiles dir prefix
2240− runInDir dir (s dir)
2242−copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243−copyTestDataFiles dir prefix = do
2244− -- Copy all the test data files to the temporary workspace
2245− testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246− for_ testDataFiles $ \f -> do
2247− createDirectoryIfMissing True $ dir </> takeDirectory f
2248− copyFile ("test/data" </> prefix </> f) (dir </> f)
2250−run' :: (FilePath -> Session a) -> IO a
2251−run' s = withTempDir $ \dir -> runInDir dir (s dir)
2253−runInDir :: FilePath -> Session a -> IO a
2255 ghcideExe <- locateGhcideExecutable
546 ghcideExe <- locateGhcideExecutable
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"
2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
547+ let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
548 -- HIE calls getXgdDirectory which assumes that HOME is set.
2264 -- Only sets HOME if it wasn't already set.
549 -- Only sets HOME if it wasn't already set.
2265 setEnv "HOME" "/homeless-shelter" False
550 setEnv "HOME" "/homeless-shelter" False
2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
551+ runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2267− runSessionWithConfig conf cmd lspTestCaps dir s
2269 conf = defaultConfig
553 conf = defaultConfig
2270− -- If you uncomment this you can see all logging
554+ -- If you uncomment this you can see all messages
2271 -- which can be quite useful for debugging.
555 -- 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 }
556+ -- { logMessages = True, logColor = False, logStdErr = True }
2276−openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2277−openTestDataDoc path = do
2278− source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
2281−findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282−findCodeActions doc range expectedTitles = do
2283− actions <- getCodeActions doc range
2284− let matches = sequence
2287− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288− , actionTitle == expectedTitle ]
2289− | expectedTitle <- expectedTitles]
2292− | CACodeAction CodeAction { _title = actionTitle } <- actions
2294− ++ " is not a superset of "
2295− ++ show expectedTitles
2296− liftIO $ case matches of
2297− Nothing -> assertFailure msg
2299− return (fromJust matches)
2301−findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302−findCodeAction doc range t = head <$> findCodeActions doc range [t]
2304−unitTests :: TestTree
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:"
2315− , testCase "from empty path URI" $ do
2316− let uri = Uri "file://"
2317− uriToFilePath' uri @?= Just ""
2320−positionMappingTests :: TestTree
2321−positionMappingTests =
2322− testGroup "position mapping"
2323− [ testGroup "toCurrent"
2324− [ testCase "before" $
2326− (Range (Position 0 1) (Position 0 3))
2328− (Position 0 0) @?= Just (Position 0 0)
2329− , testCase "after, same line, same length" $
2331− (Range (Position 0 1) (Position 0 3))
2333− (Position 0 3) @?= Just (Position 0 3)
2334− , testCase "after, same line, increased length" $
2336− (Range (Position 0 1) (Position 0 3))
2338− (Position 0 3) @?= Just (Position 0 4)
2339− , testCase "after, same line, decreased length" $
2341− (Range (Position 0 1) (Position 0 3))
2343− (Position 0 3) @?= Just (Position 0 2)
2344− , testCase "after, next line, no newline" $
2346− (Range (Position 0 1) (Position 0 3))
2348− (Position 1 3) @?= Just (Position 1 3)
2349− , testCase "after, next line, newline" $
2351− (Range (Position 0 1) (Position 0 3))
2353− (Position 1 0) @?= Just (Position 2 0)
2354− , testCase "after, same line, newline" $
2356− (Range (Position 0 1) (Position 0 3))
2358− (Position 0 4) @?= Just (Position 1 2)
2359− , testCase "after, same line, newline + newline at end" $
2361− (Range (Position 0 1) (Position 0 3))
2363− (Position 0 4) @?= Just (Position 2 1)
2364− , testCase "after, same line, newline + newline at end" $
2366− (Range (Position 0 1) (Position 0 1))
2368− (Position 0 1) @?= Just (Position 0 4)
2370− , testGroup "fromCurrent"
2371− [ testCase "before" $
2373− (Range (Position 0 1) (Position 0 3))
2375− (Position 0 0) @?= Just (Position 0 0)
2376− , testCase "after, same line, same length" $
2378− (Range (Position 0 1) (Position 0 3))
2380− (Position 0 3) @?= Just (Position 0 3)
2381− , testCase "after, same line, increased length" $
2383− (Range (Position 0 1) (Position 0 3))
2385− (Position 0 4) @?= Just (Position 0 3)
2386− , testCase "after, same line, decreased length" $
2388− (Range (Position 0 1) (Position 0 3))
2390− (Position 0 2) @?= Just (Position 0 3)
2391− , testCase "after, next line, no newline" $
2393− (Range (Position 0 1) (Position 0 3))
2395− (Position 1 3) @?= Just (Position 1 3)
2396− , testCase "after, next line, newline" $
2398− (Range (Position 0 1) (Position 0 3))
2400− (Position 2 0) @?= Just (Position 1 0)
2401− , testCase "after, same line, newline" $
2403− (Range (Position 0 1) (Position 0 3))
2405− (Position 1 2) @?= Just (Position 0 4)
2406− , testCase "after, same line, newline + newline at end" $
2408− (Range (Position 0 1) (Position 0 3))
2410− (Position 2 1) @?= Just (Position 0 4)
2411− , testCase "after, same line, newline + newline at end" $
2413− (Range (Position 0 1) (Position 0 1))
2415− (Position 0 4) @?= Just (Position 0 1)
2417− , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
2418− [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
2419− -- Note that it is important to use suchThatMap on all values at once
2420− -- instead of only using it on the position. Otherwise you can get
2421− -- into situations where there is no position that can be mapped back
2422− -- for the edit which will result in QuickCheck looping forever.
2425− range <- genRange rope
2426− PrintableText replacement <- arbitrary
2427− oldPos <- genPosition rope
2428− pure (range, replacement, oldPos)
2431− (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
2432− \(range, replacement, oldPos, newPos) ->
2433− fromCurrent range replacement newPos === Just oldPos
2434− , testProperty "toCurrent r t <=< fromCurrent r t" $ do
2437− range <- genRange rope
2438− PrintableText replacement <- arbitrary
2439− let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
2440− newPos <- genPosition newRope
2441− pure (range, replacement, newPos)
2444− (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445− \(range, replacement, newPos, oldPos) ->
2446− toCurrent range replacement oldPos === Just newPos
2450−newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2453−instance Arbitrary PrintableText where
2454− arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2458−genRope = Rope.fromText . getPrintableText <$> arbitrary
2460−genPosition :: Rope -> Gen Position
2462− row <- choose (0, max 0 $ rows - 1)
2463− let columns = Rope.columns (nthLine row r)
2464− column <- choose (0, max 0 $ columns - 1)
2465− pure $ Position row column
2466− where rows = Rope.rows r
2468−genRange :: Rope -> Gen Range
2470− startPos@(Position startLine startColumn) <- genPosition r
2471− let maxLineDiff = max 0 $ rows - 1 - startLine
2472− endLine <- choose (startLine, startLine + maxLineDiff)
2473− let columns = Rope.columns (nthLine endLine r)
2475− if startLine == endLine
2476− then choose (startColumn, columns)
2477− else choose (0, max 0 $ columns - 1)
2478− pure $ Range startPos (Position endLine endColumn)
2479− where rows = Rope.rows r
2481−-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482−nthLine :: Int -> Rope -> Rope
2484− | i < 0 = error $ "Negative line number: " <> show i
2485− | i == 0 && Rope.rows r == 0 = r
2486− | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2487− | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490−getWatchedFilesSubscriptionsUntil = do
2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs