@@ -1,43 +1,158 @@
11-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4+{-# LANGUAGE AllowAmbiguousTypes #-}
45{-# LANGUAGE DuplicateRecordFields #-}
6+{-# LANGUAGE PatternSynonyms #-}
57{-# LANGUAGE CPP #-}
68#include "ghc-api-version.h"
79
810module Main (main) where
911
10−import Control.Monad (void)
12+import Control.Applicative.Combinators
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
15+import Control.Monad
1116import Control.Monad.IO.Class (liftIO)
17+import Data.Aeson (FromJSON, Value)
18+import Data.Foldable
19+import Data.List.Extra
20+import Data.Rope.UTF16 (Rope)
21+import qualified Data.Rope.UTF16 as Rope
22+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
23+import Development.IDE.GHC.Util
1224import qualified Data.Text as T
25+import Data.Typeable
26+import Development.IDE.Spans.Common
1327import Development.IDE.Test
1428import Development.IDE.Test.Runfiles
29+import Development.IDE.Types.Location
30+import Development.Shake (getDirectoryFilesIO)
1531import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
1633import Language.Haskell.LSP.Types
1734import Language.Haskell.LSP.Types.Capabilities
18−import System.Environment.Blank (setEnv)
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
36+import Language.Haskell.LSP.VFS (applyChange)
37+import Network.URI
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
39+import System.FilePath
1940import System.IO.Extra
41+import System.Directory
42+import Test.QuickCheck
43+import Test.QuickCheck.Instances ()
2044import Test.Tasty
45+import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
2147import Test.Tasty.HUnit
22−
48+import Test.Tasty.QuickCheck
49+import Data.Maybe
2350
2451main :: IO ()
25−main = defaultMain $ testGroup "HIE"
26− [ testSession "open close" $ do
27− doc <- openDoc' "Testing.hs" "haskell" ""
28− void (message :: Session ProgressStartNotification)
29− closeDoc doc
30− void (message :: Session ProgressDoneNotification)
31− , diagnosticTests
32− , codeActionTests
33− ]
52+main = do
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
55+ defaultMainWithRerun $ testGroup "HIE"
56+ [ testSession "open close" $ do
57+ doc <- createDoc "Testing.hs" "haskell" ""
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
60+ closeDoc doc
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
62+ , initializeResponseTests
63+ , completionTests
64+ , cppTests
65+ , diagnosticTests
66+ , codeActionTests
67+ , codeLensesTests
68+ , outlineTests
69+ , findDefinitionAndHoverTests
70+ , pluginTests
71+ , preprocessorTests
72+ , thTests
73+ , safeTests
74+ , unitTests
75+ , haddockTests
76+ , positionMappingTests
77+ , watchedFilesTests
78+ , cradleTests
79+ , dependentFileTest
80+ ]
81+
82+initializeResponseTests :: TestTree
83+initializeResponseTests = withResource acquire release tests where
84+
85+ -- these tests document and monitor the evolution of the
86+ -- capabilities announced by the server in the initialize
87+ -- response. Currently the server advertises almost no capabilities
88+ -- at all, in some cases failing to announce capabilities that it
89+ -- actually does provide! Hopefully this will change ...
90+ tests :: IO InitializeResponse -> TestTree
91+ tests getInitializeResponse =
92+ testGroup "initialize response capabilities"
93+ [ chk " text doc sync" _textDocumentSync tds
94+ , chk " hover" _hoverProvider (Just True)
95+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
96+ , chk "NO signature help" _signatureHelpProvider Nothing
97+ , chk " goto definition" _definitionProvider (Just True)
98+ , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
99+ , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
100+ , chk "NO find references" _referencesProvider Nothing
101+ , chk "NO doc highlight" _documentHighlightProvider Nothing
102+ , chk " doc symbol" _documentSymbolProvider (Just True)
103+ , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
104+ , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
105+ , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
106+ , chk "NO doc formatting" _documentFormattingProvider Nothing
107+ , chk "NO doc range formatting"
108+ _documentRangeFormattingProvider Nothing
109+ , chk "NO doc formatting on typing"
110+ _documentOnTypeFormattingProvider Nothing
111+ , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False)
112+ , chk "NO doc link" _documentLinkProvider Nothing
113+ , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114+ , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
117+ , chk "NO experimental" _experimental Nothing
118+ ] where
119+
120+ tds = Just (TDSOptions (TextDocumentSyncOptions
121+ { _openClose = Just True
122+ , _change = Just TdSyncIncremental
123+ , _willSave = Nothing
124+ , _willSaveWaitUntil = Nothing
125+ , _save = Just (SaveOptions {_includeText = Nothing})}))
126+
127+ chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
128+ chk title getActual expected =
129+ testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
130+
131+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132+ che title getActual _expected = testCase title doTest
133+ where
134+ doTest = do
135+ ir <- getInitializeResponse
136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137+ True @=? T.isSuffixOf "typesignature.add" command
138+
139+
140+ innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
142+ innerCaps _ = error "this test only expects inner capabilities"
143+
144+ acquire :: IO InitializeResponse
145+ acquire = run initializeResponse
146+
147+ release :: InitializeResponse -> IO ()
148+ release = const $ pure ()
34149
35150
36151diagnosticTests :: TestTree
37152diagnosticTests = testGroup "diagnostics"
38− [ testSession "fix syntax error" $ do
153+ [ testSessionWait "fix syntax error" $ do
39154 let content = T.unlines [ "module Testing wher" ]
40− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
41156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
42157 let change = TextDocumentContentChangeEvent
43158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -46,10 +161,11 @@ diagnosticTests = testGroup "diagnostics"
46161 }
47162 changeDoc doc [change]
48163 expectDiagnostics [("Testing.hs", [])]
49− , testSession "introduce syntax error" $ do
164+ , testSessionWait "introduce syntax error" $ do
50165 let content = T.unlines [ "module Testing where" ]
51− doc <- openDoc' "Testing.hs" "haskell" content
52− void (message :: Session ProgressStartNotification)
166+ doc <- createDoc "Testing.hs" "haskell" content
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
53169 let change = TextDocumentContentChangeEvent
54170 { _range = Just (Range (Position 0 15) (Position 0 18))
55171 , _rangeLength = Nothing
@@ -57,7 +173,7 @@ diagnosticTests = testGroup "diagnostics"
57173 }
58174 changeDoc doc [change]
59175 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
60− , testSession "variable not in scope" $ do
176+ , testSessionWait "variable not in scope" $ do
61177 let content = T.unlines
62178 [ "module Testing where"
63179 , "foo :: Int -> Int -> Int"
@@ -65,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
65181 , "bar :: Int -> Int -> Int"
66182 , "bar a b = cd + b"
67183 ]
68− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
69185 expectDiagnostics
70186 [ ( "Testing.hs"
71187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -73,25 +189,25 @@ diagnosticTests = testGroup "diagnostics"
73189 ]
74190 )
75191 ]
76− , testSession "type error" $ do
192+ , testSessionWait "type error" $ do
77193 let content = T.unlines
78194 [ "module Testing where"
79195 , "foo :: Int -> String -> Int"
80196 , "foo a b = a + b"
81197 ]
82− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
83199 expectDiagnostics
84200 [ ( "Testing.hs"
85201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
86202 )
87203 ]
88− , testSession "typed hole" $ do
204+ , testSessionWait "typed hole" $ do
89205 let content = T.unlines
90206 [ "module Testing where"
91207 , "foo :: Int -> String"
92208 , "foo a = _ a"
93209 ]
94− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
95211 expectDiagnostics
96212 [ ( "Testing.hs"
97213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -112,24 +228,24 @@ diagnosticTests = testGroup "diagnostics"
112228 expectedDs aMessage =
113229 [ ("A.hs", [(DsError, (2,4), aMessage)])
114230 , ("B.hs", [(DsError, (3,4), bMessage)])]
115− deferralTest title binding message = testSession title $ do
116− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
117− _ <- openDoc' "B.hs" "haskell" sourceB
118− expectDiagnostics $ expectedDs message
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
119235 in
120− [ deferralTest "type error" "True" "Couldn't match expected type"
121− , deferralTest "typed hole" "_" "Found hole"
122− , deferralTest "out of scope var" "unbound" "Variable not in scope"
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"
123239 ]
124240
125− , testSession "remove required module" $ do
241+ , testSessionWait "remove required module" $ do
126242 let contentA = T.unlines [ "module ModuleA where" ]
127− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
128244 let contentB = T.unlines
129245 [ "module ModuleB where"
130246 , "import ModuleA"
131247 ]
132− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
133249 let change = TextDocumentContentChangeEvent
134250 { _range = Just (Range (Position 0 0) (Position 0 20))
135251 , _rangeLength = Nothing
@@ -137,17 +253,27 @@ diagnosticTests = testGroup "diagnostics"
137253 }
138254 changeDoc docA [change]
139255 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
140− , testSession "add missing module" $ do
256+ , testSessionWait "add missing module" $ do
141257 let contentB = T.unlines
142258 [ "module ModuleB where"
143259 , "import ModuleA"
144260 ]
145− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
146262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
147263 let contentA = T.unlines [ "module ModuleA where" ]
148− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
149265 expectDiagnostics [("ModuleB.hs", [])]
150− , testSession "cyclic module dependency" $ do
266+ , testSessionWait "add missing module (non workspace)" $ do
267+ let contentB = T.unlines
268+ [ "module ModuleB where"
269+ , "import ModuleA"
270+ ]
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272+ expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273+ let contentA = T.unlines [ "module ModuleA where" ]
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275+ expectDiagnostics [("/tmp/ModuleB.hs", [])]
276+ , testSessionWait "cyclic module dependency" $ do
151277 let contentA = T.unlines
152278 [ "module ModuleA where"
153279 , "import ModuleB"
@@ -156,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
156282 [ "module ModuleB where"
157283 , "import ModuleA"
158284 ]
159− _ <- openDoc' "ModuleA.hs" "haskell" contentA
160− _ <- openDoc' "ModuleB.hs" "haskell" contentB
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
161287 expectDiagnostics
162288 [ ( "ModuleA.hs"
163289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -166,7 +292,7 @@ diagnosticTests = testGroup "diagnostics"
166292 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
167293 )
168294 ]
169− , testSession "cyclic module dependency with hs-boot" $ do
295+ , testSessionWait "cyclic module dependency with hs-boot" $ do
170296 let contentA = T.unlines
171297 [ "module ModuleA where"
172298 , "import {-# SOURCE #-} ModuleB"
@@ -178,11 +304,11 @@ diagnosticTests = testGroup "diagnostics"
178304 let contentBboot = T.unlines
179305 [ "module ModuleB where"
180306 ]
181− _ <- openDoc' "ModuleA.hs" "haskell" contentA
182− _ <- openDoc' "ModuleB.hs" "haskell" contentB
183− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
184310 expectDiagnostics []
185− , testSession "correct reference used with hs-boot" $ do
311+ , testSessionWait "correct reference used with hs-boot" $ do
186312 let contentB = T.unlines
187313 [ "module ModuleB where"
188314 , "import {-# SOURCE #-} ModuleA"
@@ -202,28 +328,29 @@ diagnosticTests = testGroup "diagnostics"
202328 -- resolved to the hs-boot file
203329 , "y = x"
204330 ]
205− _ <- openDoc' "ModuleB.hs" "haskell" contentB
206− _ <- openDoc' "ModuleA.hs" "haskell" contentA
207− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
208− _ <- openDoc' "ModuleC.hs" "haskell" contentC
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
209335 expectDiagnostics []
210− , testSession "redundant import" $ do
336+ , testSessionWait "redundant import" $ do
211337 let contentA = T.unlines ["module ModuleA where"]
212338 let contentB = T.unlines
213339 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
214340 , "module ModuleB where"
215341 , "import ModuleA"
216342 ]
217− _ <- openDoc' "ModuleA.hs" "haskell" contentA
218− _ <- openDoc' "ModuleB.hs" "haskell" contentB
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
219345 expectDiagnostics
220346 [ ( "ModuleB.hs"
221347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
222348 )
223349 ]
224− , testSession "package imports" $ do
350+ , testSessionWait "package imports" $ do
225351 let thisDataListContent = T.unlines
226352 [ "module Data.List where"
353+ , "x :: Integer"
227354 , "x = 123"
228355 ]
229356 let mainContent = T.unlines
@@ -236,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
236363 , "wrong1 = ThisList.map"
237364 , "wrong2 = BaseList.x"
238365 ]
239− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
240− _ <- openDoc' "Main.hs" "haskell" mainContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
241368 expectDiagnostics
242369 [ ( "Main.hs"
243370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -245,14 +372,14 @@ diagnosticTests = testGroup "diagnostics"
245372 ]
246373 )
247374 ]
248− , testSession "unqualified warnings" $ do
375+ , testSessionWait "unqualified warnings" $ do
249376 let fooContent = T.unlines
250377 [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
251378 , "module Foo where"
252379 , "foo :: Ord a => a -> Int"
253380 , "foo a = 1"
254381 ]
255− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
256383 expectDiagnostics
257384 [ ( "Foo.hs"
258385 -- The test is to make sure that warnings contain unqualified names
@@ -263,6 +390,72 @@ diagnosticTests = testGroup "diagnostics"
263390 ]
264391 )
265392 ]
393+ , testSessionWait "lower-case drive" $ do
394+ let aContent = T.unlines
395+ [ "module A.A where"
396+ , "import A.B ()"
397+ ]
398+ bContent = T.unlines
399+ [ "{-# OPTIONS_GHC -Wall #-}"
400+ , "module A.B where"
401+ , "import Data.List"
402+ ]
403+ uriB <- getDocUri "A/B.hs"
404+ Just pathB <- pure $ uriToFilePath uriB
405+ uriB <- pure $
406+ let (drive, suffix) = splitDrive pathB
407+ in filePathToUri (joinDrive (lower drive) suffix)
408+ liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409+ liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410+ uriA <- getDocUri "A/A.hs"
411+ Just pathA <- pure $ uriToFilePath uriA
412+ uriA <- pure $
413+ let (drive, suffix) = splitDrive pathA
414+ in filePathToUri (joinDrive (lower drive) suffix)
415+ let itemA = TextDocumentItem uriA "haskell" 0 aContent
416+ let a = TextDocumentIdentifier uriA
417+ sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418+ diagsNot <- skipManyTill anyMessage diagnostic
419+ let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420+ -- Check that if we put a lower-case drive in for A.A
421+ -- the diagnostics for A.B will also be lower-case.
422+ liftIO $ fileUri @?= uriB
423+ let msg = _message (head (toList diags) :: Diagnostic)
424+ liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425+ assertFailure ("Expected redundant import but got " <> T.unpack msg)
426+ closeDoc a
427+ , testSessionWait "haddock parse error" $ do
428+ let fooContent = T.unlines
429+ [ "module Foo where"
430+ , "foo :: Int"
431+ , "foo = 1 {-|-}"
432+ ]
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
434+ expectDiagnostics
435+ [ ( "Foo.hs"
436+ , [(DsError, (2, 8), "Parse error on input")
437+ ]
438+ )
439+ ]
440+ , testSessionWait "strip file path" $ do
441+ let
442+ name = "Testing"
443+ content = T.unlines
444+ [ "module " <> name <> " where"
445+ , "value :: Maybe ()"
446+ , "value = [()]"
447+ ]
448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449+ notification <- skipManyTill anyMessage diagnostic
450+ let
451+ offenders =
452+ Lsp.params .
453+ Lsp.diagnostics .
454+ Lens.folded .
455+ Lsp.message .
456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458+ Lens.mapMOf_ offenders failure notification
266459 ]
267460
268461codeActionTests :: TestTree
@@ -270,9 +463,46 @@ codeActionTests = testGroup "code actions"
270463 [ renameActionTests
271464 , typeWildCardActionTests
272465 , removeImportTests
466+ , extendImportTests
467+ , suggestImportTests
468+ , addExtensionTests
469+ , fixConstructorImportTests
273470 , importRenameActionTests
274471 , fillTypedHoleTests
275472 , addSigActionTests
473+ , insertNewDefinitionTests
474+ ]
475+
476+codeLensesTests :: TestTree
477+codeLensesTests = testGroup "code lenses"
478+ [ addSigLensesTests
479+ ]
480+
481+watchedFilesTests :: TestTree
482+watchedFilesTests = testGroup "watched files"
483+ [ testSession' "workspace files" $ \sessionDir -> do
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
487+
488+ -- Expect 4 subscriptions (A does not get any because it's VFS):
489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493+ liftIO $ length watchedFileRegs @?= 4
494+
495+ , testSession' "non workspace file" $ \sessionDir -> do
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
499+
500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503+ liftIO $ length watchedFileRegs @?= 2
504+
505+ -- TODO add a test for didChangeWorkspaceFolder
276506 ]
277507
278508renameActionTests :: TestTree
@@ -283,11 +513,9 @@ renameActionTests = testGroup "rename actions"
283513 , "foo :: Int -> Int"
284514 , "foo argName = argNme"
285515 ]
286− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
287517 _ <- waitForDiagnostics
288− [CACodeAction action@CodeAction { _title = actionTitle }]
289− <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
290− liftIO $ "Replace with ‘argName’" @=? actionTitle
518+ action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
291519 executeCodeAction action
292520 contentAfterAction <- documentContents doc
293521 let expectedContentAfterAction = T.unlines
@@ -303,11 +531,9 @@ renameActionTests = testGroup "rename actions"
303531 , "foo :: Maybe a -> [a]"
304532 , "foo = maybToList"
305533 ]
306− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
307535 _ <- waitForDiagnostics
308− [CACodeAction action@CodeAction { _title = actionTitle }]
309− <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
310− liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
536+ action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
311537 executeCodeAction action
312538 contentAfterAction <- documentContents doc
313539 let expectedContentAfterAction = T.unlines
@@ -323,12 +549,11 @@ renameActionTests = testGroup "rename actions"
323549 , "foo :: Char -> Char -> Char -> Char"
324550 , "foo argument1 argument2 argument3 = argumentX"
325551 ]
326− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
327553 _ <- waitForDiagnostics
328− actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
329− let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
330− expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
331− liftIO $ expectedActionTitles @=? actionTitles
554+ _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
555+ ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
556+ return()
332557 , testSession "change infix function" $ do
333558 let content = T.unlines
334559 [ "module Testing where"
@@ -336,7 +561,7 @@ renameActionTests = testGroup "rename actions"
336561 , "monus x y = max 0 (x - y)"
337562 , "foo x y = x `monnus` y"
338563 ]
339− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
340565 _ <- waitForDiagnostics
341566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
342567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -359,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
359584 , "func :: _"
360585 , "func x = x"
361586 ]
362− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
363588 _ <- waitForDiagnostics
364589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
365590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -379,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
379604 , "func :: _"
380605 , "func x y = x + y"
381606 ]
382− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
383608 _ <- waitForDiagnostics
384609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
385610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -402,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
402627 , " y = x * 2"
403628 , " in y"
404629 ]
405− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
406631 _ <- waitForDiagnostics
407632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
408633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -427,14 +652,15 @@ removeImportTests = testGroup "remove import actions"
427652 let contentA = T.unlines
428653 [ "module ModuleA where"
429654 ]
430− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
431656 let contentB = T.unlines
432657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
433658 , "module ModuleB where"
434659 , "import ModuleA"
660+ , "stuffB :: Integer"
435661 , "stuffB = 123"
436662 ]
437− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
438664 _ <- waitForDiagnostics
439665 [CACodeAction action@CodeAction { _title = actionTitle }]
440666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -444,6 +670,7 @@ removeImportTests = testGroup "remove import actions"
444670 let expectedContentAfterAction = T.unlines
445671 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
446672 , "module ModuleB where"
673+ , "stuffB :: Integer"
447674 , "stuffB = 123"
448675 ]
449676 liftIO $ expectedContentAfterAction @=? contentAfterAction
@@ -451,14 +678,15 @@ removeImportTests = testGroup "remove import actions"
451678 let contentA = T.unlines
452679 [ "module ModuleA where"
453680 ]
454− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
455682 let contentB = T.unlines
456683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
457684 , "module ModuleB where"
458685 , "import qualified ModuleA"
686+ , "stuffB :: Integer"
459687 , "stuffB = 123"
460688 ]
461− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
462690 _ <- waitForDiagnostics
463691 [CACodeAction action@CodeAction { _title = actionTitle }]
464692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -468,10 +696,457 @@ removeImportTests = testGroup "remove import actions"
468696 let expectedContentAfterAction = T.unlines
469697 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
470698 , "module ModuleB where"
699+ , "stuffB :: Integer"
700+ , "stuffB = 123"
701+ ]
702+ liftIO $ expectedContentAfterAction @=? contentAfterAction
703+ , testSession "redundant binding" $ do
704+ let contentA = T.unlines
705+ [ "module ModuleA where"
706+ , "stuffA = False"
707+ , "stuffB :: Integer"
708+ , "stuffB = 123"
709+ , "stuffC = ()"
710+ ]
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
712+ let contentB = T.unlines
713+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714+ , "module ModuleB where"
715+ , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716+ , "main = print stuffB"
717+ ]
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
719+ _ <- waitForDiagnostics
720+ [CACodeAction action@CodeAction { _title = actionTitle }]
721+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
722+ liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
723+ executeCodeAction action
724+ contentAfterAction <- documentContents docB
725+ let expectedContentAfterAction = T.unlines
726+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
727+ , "module ModuleB where"
728+ , "import ModuleA (stuffB)"
729+ , "main = print stuffB"
730+ ]
731+ liftIO $ expectedContentAfterAction @=? contentAfterAction
732+ , testSession "redundant operator" $ do
733+ let contentA = T.unlines
734+ [ "module ModuleA where"
735+ , "a !! b = a"
736+ , "a <?> b = a"
737+ , "stuffB :: Integer"
738+ , "stuffB = 123"
739+ ]
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
741+ let contentB = T.unlines
742+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743+ , "module ModuleB where"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745+ , "main = print A.stuffB"
746+ ]
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
748+ _ <- waitForDiagnostics
749+ [CACodeAction action@CodeAction { _title = actionTitle }]
750+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
752+ executeCodeAction action
753+ contentAfterAction <- documentContents docB
754+ let expectedContentAfterAction = T.unlines
755+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756+ , "module ModuleB where"
757+ , "import qualified ModuleA as A (stuffB)"
758+ , "main = print A.stuffB"
759+ ]
760+ liftIO $ expectedContentAfterAction @=? contentAfterAction
761+ , testSession "redundant all import" $ do
762+ let contentA = T.unlines
763+ [ "module ModuleA where"
764+ , "data A = A"
765+ , "stuffB :: Integer"
471766 , "stuffB = 123"
472767 ]
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
769+ let contentB = T.unlines
770+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771+ , "module ModuleB where"
772+ , "import ModuleA (A(..), stuffB)"
773+ , "main = print stuffB"
774+ ]
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
776+ _ <- waitForDiagnostics
777+ [CACodeAction action@CodeAction { _title = actionTitle }]
778+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
779+ liftIO $ "Remove A from import" @=? actionTitle
780+ executeCodeAction action
781+ contentAfterAction <- documentContents docB
782+ let expectedContentAfterAction = T.unlines
783+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
784+ , "module ModuleB where"
785+ , "import ModuleA (stuffB)"
786+ , "main = print stuffB"
787+ ]
473788 liftIO $ expectedContentAfterAction @=? contentAfterAction
789+ , testSession "redundant constructor import" $ do
790+ let contentA = T.unlines
791+ [ "module ModuleA where"
792+ , "data D = A | B"
793+ , "data E = F"
794+ ]
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
796+ let contentB = T.unlines
797+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798+ , "module ModuleB where"
799+ , "import ModuleA (D(A,B), E(F))"
800+ , "main = B"
801+ ]
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
803+ _ <- waitForDiagnostics
804+ [CACodeAction action@CodeAction { _title = actionTitle }]
805+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
806+ liftIO $ "Remove A, E, F from import" @=? actionTitle
807+ executeCodeAction action
808+ contentAfterAction <- documentContents docB
809+ let expectedContentAfterAction = T.unlines
810+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
811+ , "module ModuleB where"
812+ , "import ModuleA (D(B))"
813+ , "main = B"
814+ ]
815+ liftIO $ expectedContentAfterAction @=? contentAfterAction
816+ ]
817+
818+extendImportTests :: TestTree
819+extendImportTests = testGroup "extend import actions"
820+ [ testSession "extend single line import with value" $ template
821+ (T.unlines
822+ [ "module ModuleA where"
823+ , "stuffA :: Double"
824+ , "stuffA = 0.00750"
825+ , "stuffB :: Integer"
826+ , "stuffB = 123"
827+ ])
828+ (T.unlines
829+ [ "module ModuleB where"
830+ , "import ModuleA as A (stuffB)"
831+ , "main = print (stuffA, stuffB)"
832+ ])
833+ (Range (Position 3 17) (Position 3 18))
834+ "Add stuffA to the import list of ModuleA"
835+ (T.unlines
836+ [ "module ModuleB where"
837+ , "import ModuleA as A (stuffA, stuffB)"
838+ , "main = print (stuffA, stuffB)"
839+ ])
840+ , testSession "extend single line import with operator" $ template
841+ (T.unlines
842+ [ "module ModuleA where"
843+ , "(.*) :: Integer -> Integer -> Integer"
844+ , "x .* y = x * y"
845+ , "stuffB :: Integer"
846+ , "stuffB = 123"
847+ ])
848+ (T.unlines
849+ [ "module ModuleB where"
850+ , "import ModuleA as A (stuffB)"
851+ , "main = print (stuffB .* stuffB)"
852+ ])
853+ (Range (Position 3 17) (Position 3 18))
854+ "Add .* to the import list of ModuleA"
855+ (T.unlines
856+ [ "module ModuleB where"
857+ , "import ModuleA as A ((.*), stuffB)"
858+ , "main = print (stuffB .* stuffB)"
859+ ])
860+ , testSession "extend single line import with type" $ template
861+ (T.unlines
862+ [ "module ModuleA where"
863+ , "type A = Double"
864+ ])
865+ (T.unlines
866+ [ "module ModuleB where"
867+ , "import ModuleA ()"
868+ , "b :: A"
869+ , "b = 0"
870+ ])
871+ (Range (Position 2 5) (Position 2 5))
872+ "Add A to the import list of ModuleA"
873+ (T.unlines
874+ [ "module ModuleB where"
875+ , "import ModuleA (A)"
876+ , "b :: A"
877+ , "b = 0"
878+ ])
879+ , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template
880+ (T.unlines
881+ [ "module ModuleA where"
882+ , "data A = Constructor"
883+ ])
884+ (T.unlines
885+ [ "module ModuleB where"
886+ , "import ModuleA (A)"
887+ , "b :: A"
888+ , "b = Constructor"
889+ ])
890+ (Range (Position 2 5) (Position 2 5))
891+ "Add Constructor to the import list of ModuleA"
892+ (T.unlines
893+ [ "module ModuleB where"
894+ , "import ModuleA (A(Constructor))"
895+ , "b :: A"
896+ , "b = Constructor"
897+ ])
898+ , testSession "extend single line qualified import with value" $ template
899+ (T.unlines
900+ [ "module ModuleA where"
901+ , "stuffA :: Double"
902+ , "stuffA = 0.00750"
903+ , "stuffB :: Integer"
904+ , "stuffB = 123"
905+ ])
906+ (T.unlines
907+ [ "module ModuleB where"
908+ , "import qualified ModuleA as A (stuffB)"
909+ , "main = print (A.stuffA, A.stuffB)"
910+ ])
911+ (Range (Position 3 17) (Position 3 18))
912+ "Add stuffA to the import list of ModuleA"
913+ (T.unlines
914+ [ "module ModuleB where"
915+ , "import qualified ModuleA as A (stuffA, stuffB)"
916+ , "main = print (A.stuffA, A.stuffB)"
917+ ])
918+ , testSession "extend multi line import with value" $ template
919+ (T.unlines
920+ [ "module ModuleA where"
921+ , "stuffA :: Double"
922+ , "stuffA = 0.00750"
923+ , "stuffB :: Integer"
924+ , "stuffB = 123"
925+ ])
926+ (T.unlines
927+ [ "module ModuleB where"
928+ , "import ModuleA (stuffB"
929+ , " )"
930+ , "main = print (stuffA, stuffB)"
931+ ])
932+ (Range (Position 3 17) (Position 3 18))
933+ "Add stuffA to the import list of ModuleA"
934+ (T.unlines
935+ [ "module ModuleB where"
936+ , "import ModuleA (stuffA, stuffB"
937+ , " )"
938+ , "main = print (stuffA, stuffB)"
939+ ])
940+ ]
941+ where
942+ template contentA contentB range expectedAction expectedContentB = do
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
945+ _ <- waitForDiagnostics
946+ CACodeAction action@CodeAction { _title = actionTitle } : _
947+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
948+ getCodeActions docB range
949+ liftIO $ expectedAction @=? actionTitle
950+ executeCodeAction action
951+ contentAfterAction <- documentContents docB
952+ liftIO $ expectedContentB @=? contentAfterAction
953+
954+suggestImportTests :: TestTree
955+suggestImportTests = testGroup "suggest import actions"
956+ [ testGroup "Dont want suggestion"
957+ [ -- extend import
958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
959+ -- data constructor
960+ , test False [] "f = First" [] "import Data.Monoid (First)"
961+ -- internal module
962+ , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963+ -- package not in scope
964+ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
965+ ]
966+ , testGroup "want suggestion"
967+ [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
968+ , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969+ , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970+ , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
971+ , test True [] "f = First" [] "import Data.Monoid (First(First))"
972+ , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973+ , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974+ , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975+ , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
976+ , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979+ , test True [] "f = (&)" [] "import Data.Function ((&))"
980+ , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
981+ , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982+ , test True [] "f = pack" [] "import Data.Text (pack)"
983+ , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984+ , test True [] "f = [] & id" [] "import Data.Function ((&))"
985+ , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
986+ ]
987+ ]
988+ where
989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990+ let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991+ after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992+ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993+ liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994+ doc <- createDoc "Test.hs" "haskell" before
995+ _diags <- waitForDiagnostics
996+ let defLine = length imps + 1
997+ range = Range (Position defLine 0) (Position defLine maxBound)
998+ actions <- getCodeActions doc range
999+ if wanted
1000+ then do
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1005+ else
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007+
1008+
1009+addExtensionTests :: TestTree
1010+addExtensionTests = testGroup "add language extension actions"
1011+ [ testSession "add NamedFieldPuns language extension" $ template
1012+ (T.unlines
1013+ [ "module Module where"
1014+ , ""
1015+ , "data A = A { getA :: Bool }"
1016+ , ""
1017+ , "f :: A -> Bool"
1018+ , "f A { getA } = getA"
1019+ ])
1020+ (Range (Position 0 0) (Position 0 0))
1021+ "Add NamedFieldPuns extension"
1022+ (T.unlines
1023+ [ "{-# LANGUAGE NamedFieldPuns #-}"
1024+ , "module Module where"
1025+ , ""
1026+ , "data A = A { getA :: Bool }"
1027+ , ""
1028+ , "f :: A -> Bool"
1029+ , "f A { getA } = getA"
1030+ ])
1031+ , testSession "add RecordWildCards language extension" $ template
1032+ (T.unlines
1033+ [ "module Module where"
1034+ , ""
1035+ , "data A = A { getA :: Bool }"
1036+ , ""
1037+ , "f :: A -> Bool"
1038+ , "f A { .. } = getA"
1039+ ])
1040+ (Range (Position 0 0) (Position 0 0))
1041+ "Add RecordWildCards extension"
1042+ (T.unlines
1043+ [ "{-# LANGUAGE RecordWildCards #-}"
1044+ , "module Module where"
1045+ , ""
1046+ , "data A = A { getA :: Bool }"
1047+ , ""
1048+ , "f :: A -> Bool"
1049+ , "f A { .. } = getA"
1050+ ])
4741051 ]
1052+ where
1053+ template initialContent range expectedAction expectedContents = do
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1055+ _ <- waitForDiagnostics
1056+ CACodeAction action@CodeAction { _title = actionTitle } : _
1057+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058+ getCodeActions doc range
1059+ liftIO $ expectedAction @=? actionTitle
1060+ executeCodeAction action
1061+ contentAfterAction <- documentContents doc
1062+ liftIO $ expectedContents @=? contentAfterAction
1063+
1064+
1065+insertNewDefinitionTests :: TestTree
1066+insertNewDefinitionTests = testGroup "insert new definition actions"
1067+ [ testSession "insert new function definition" $ do
1068+ let txtB =
1069+ ["foo True = select [True]"
1070+ , ""
1071+ ,"foo False = False"
1072+ ]
1073+ txtB' =
1074+ [""
1075+ ,"someOtherCode = ()"
1076+ ]
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1078+ _ <- waitForDiagnostics
1079+ CACodeAction action@CodeAction { _title = actionTitle } : _
1080+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1081+ getCodeActions docB (R 1 0 1 50)
1082+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1083+ executeCodeAction action
1084+ contentAfterAction <- documentContents docB
1085+ liftIO $ contentAfterAction @?= T.unlines (txtB ++
1086+ [ ""
1087+ , "select :: [Bool] -> Bool"
1088+ , "select = error \"not implemented\""
1089+ ]
1090+ ++ txtB')
1091+ , testSession "define a hole" $ do
1092+ let txtB =
1093+ ["foo True = _select [True]"
1094+ , ""
1095+ ,"foo False = False"
1096+ ]
1097+ txtB' =
1098+ [""
1099+ ,"someOtherCode = ()"
1100+ ]
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1102+ _ <- waitForDiagnostics
1103+ CACodeAction action@CodeAction { _title = actionTitle } : _
1104+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1105+ getCodeActions docB (R 1 0 1 50)
1106+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1107+ executeCodeAction action
1108+ contentAfterAction <- documentContents docB
1109+ liftIO $ contentAfterAction @?= T.unlines (
1110+ ["foo True = select [True]"
1111+ , ""
1112+ ,"foo False = False"
1113+ , ""
1114+ , "select :: [Bool] -> Bool"
1115+ , "select = error \"not implemented\""
1116+ ]
1117+ ++ txtB')
1118+ ]
1119+
1120+fixConstructorImportTests :: TestTree
1121+fixConstructorImportTests = testGroup "fix import actions"
1122+ [ testSession "fix constructor import" $ template
1123+ (T.unlines
1124+ [ "module ModuleA where"
1125+ , "data A = Constructor"
1126+ ])
1127+ (T.unlines
1128+ [ "module ModuleB where"
1129+ , "import ModuleA(Constructor)"
1130+ ])
1131+ (Range (Position 1 10) (Position 1 11))
1132+ "Fix import of A(Constructor)"
1133+ (T.unlines
1134+ [ "module ModuleB where"
1135+ , "import ModuleA(A(Constructor))"
1136+ ])
1137+ ]
1138+ where
1139+ template contentA contentB range expectedAction expectedContentB = do
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
1142+ _diags <- waitForDiagnostics
1143+ CACodeAction action@CodeAction { _title = actionTitle } : _
1144+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1145+ getCodeActions docB range
1146+ liftIO $ expectedAction @=? actionTitle
1147+ executeCodeAction action
1148+ contentAfterAction <- documentContents docB
1149+ liftIO $ expectedContentB @=? contentAfterAction
4751150
4761151importRenameActionTests :: TestTree
4771152importRenameActionTests = testGroup "import rename actions"
@@ -482,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
4821157 [ "module Testing where"
4831158 , "import Data.Mape"
4841159 ]
485− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
4861161 _ <- waitForDiagnostics
4871162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
4881163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -519,10 +1194,10 @@ fillTypedHoleTests = let
5191194 newA newB newC = testSession (T.unpack actionTitle) $ do
5201195 let originalCode = sourceCode oldA oldB oldC
5211196 let expectedCode = sourceCode newA newB newC
522− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
5231198 _ <- waitForDiagnostics
5241199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
525− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
5261201 executeCodeAction chosenAction
5271202 modifiedCode <- documentContents doc
5281203 liftIO $ expectedCode @=? modifiedCode
@@ -559,38 +1234,977 @@ fillTypedHoleTests = let
5591234
5601235addSigActionTests :: TestTree
5611236addSigActionTests = let
562− head = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
563− , "module Sigs where"]
564− before def = T.unlines [head, def]
565− after def sig = T.unlines [head, sig, def]
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]
5661241
5671242 def >:: sig = testSession (T.unpack def) $ do
5681243 let originalCode = before def
569− let expectedCode = after def sig
570− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1244+ let expectedCode = after' def sig
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
5711246 _ <- waitForDiagnostics
5721247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
573− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
5741249 executeCodeAction chosenAction
5751250 modifiedCode <- documentContents doc
5761251 liftIO $ expectedCode @=? modifiedCode
5771252 in
5781253 testGroup "add signature"
579− [ "abc = True" >:: "abc :: Bool"
580− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
581− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
582− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
583− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
584− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1254+ [ "abc = True" >:: "abc :: Bool"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1256+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1261+ ]
1262+
1263+addSigLensesTests :: TestTree
1264+addSigLensesTests = let
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1266+ notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1268+ other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1269+ before withMissing def
1270+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1271+ after' withMissing def sig
1272+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
1273+
1274+ sigSession withMissing def sig = testSession (T.unpack def) $ do
1275+ let originalCode = before withMissing def
1276+ let expectedCode = after' withMissing def sig
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1278+ [CodeLens {_command = Just c}] <- getCodeLenses doc
1279+ executeCommand c
1280+ modifiedCode <- getDocumentEdit doc
1281+ liftIO $ expectedCode @=? modifiedCode
1282+ in
1283+ testGroup "add signature"
1284+ [ testGroup title
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1286+ , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1287+ , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1292+ ]
1293+ | (title, enableWarnings) <-
1294+ [("with warnings enabled", True)
1295+ ,("with warnings disabled", False)
1296+ ]
1297+ ]
1298+
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1301+
1302+ check (ExpectRange expectedRange) = do
1303+ assertNDefinitionsFound 1 defs
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1308+ check ExpectNoDefinitions = do
1309+ assertNDefinitionsFound 0 defs
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1312+
1313+ assertNDefinitionsFound :: Int -> [a] -> Session ()
1314+ assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1315+
1316+ assertRangeCorrect Location{_range = foundRange} expectedRange =
1317+ liftIO $ expectedRange @=? foundRange
1318+
1319+
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1322+
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1327+
1328+
1329+
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1332+
1333+ check expected =
1334+ case hover of
1335+ Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
1336+ Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1337+ ,_range = rangeInHover } ->
1338+ case expected of
1339+ ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340+ ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1341+ ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342+ ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
1343+ _ -> pure () -- all other expectations not relevant to hover
1344+ _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1345+
1346+ extractLineColFromHoverMsg :: T.Text -> [T.Text]
1347+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
1348+
1349+ checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1350+ checkHoverRange expectedRange rangeInHover msg =
1351+ let
1352+ lineCol = extractLineColFromHoverMsg msg
1353+ -- looks like hovers use 1-based numbering while definitions use 0-based
1354+ -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
1355+ adjust Position{_line = l, _character = c} =
1356+ Position{_line = l + 1, _character = c + 1}
1357+ in
1358+ case map (read . T.unpack) lineCol of
1359+ [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c
1360+ _ -> liftIO $ assertFailure $
1361+ "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
1362+ "\n but got: " <> show (msg, rangeInHover)
1363+
1364+ assertFoundIn :: T.Text -> T.Text -> Assertion
1365+ assertFoundIn part whole = assertBool
1366+ (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
1367+ (part `T.isInfixOf` whole)
1368+
1369+ sourceFilePath = T.unpack sourceFileName
1370+ sourceFileName = "GotoHover.hs"
1371+
1372+ mkFindTests tests = testGroup "get"
1373+ [ testGroup "definition" $ mapMaybe fst tests
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1376+
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1378+
1379+ testM runDef runHover look expect title =
1380+ ( runDef $ tst def look expect title
1381+ , runHover $ tst hover look expect title ) where
1382+ def = (getDefinitions, checkDefs)
1383+ hover = (getHover , checkHover)
1384+ --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1385+
1386+ -- search locations expectations on results
1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1388+ fffL8 = Position 12 4 ;
1389+ fffL14 = Position 18 7 ;
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1392+ dcL12 = Position 16 11 ;
1393+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1394+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1400+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1401+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1402+ clL25 = Position 29 9
1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1405+ dnbL30 = Position 34 23
1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1407+ lclL33 = Position 37 22
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409+ mclL37 = Position 41 1
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1412+ ; constr = [ExpectHoverText ["Monad m"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421+ innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422+ imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423+ reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
1424+ in
1425+ mkFindTests
1426+ -- def hover look expect
1427+ [ test yes yes fffL4 fff "field in record definition"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1429+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1451+ , test no broken docL41 doc "documentation #7"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1461+ , test broken broken innL48 innSig "inner signature #310"
1462+ , testM yes yes imported importedSig "Imported symbol"
1463+ , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
1464+ ]
1465+ where yes, broken :: (TestTree -> Maybe TestTree)
1466+ yes = Just -- test should run and pass
1467+ broken = Just . (`xfail` "known broken")
1468+ no = const Nothing -- don't run this test at all
1469+
1470+checkFileCompiles :: FilePath -> TestTree
1471+checkFileCompiles fp =
1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473+ void (openTestDataDoc (dir </> fp))
1474+ expectNoMoreDiagnostics 0.5
1475+
1476+
1477+
1478+pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1480+ $ testSessionWait "plugins" $ do
1481+ let content =
1482+ T.unlines
1483+ [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1484+ , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"
1485+ , "module Testing where"
1486+ , "import Data.Proxy"
1487+ , "import GHC.TypeLits"
1488+ -- This function fails without plugins being initialized.
1489+ , "f :: forall n. KnownNat n => Proxy n -> Integer"
1490+ , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"
1491+ , "foo :: Int -> Int -> Int"
1492+ , "foo a b = a + c"
1493+ ]
1494+ _ <- createDoc "Testing.hs" "haskell" content
1495+ expectDiagnostics
1496+ [ ( "Testing.hs",
1497+ [(DsError, (8, 14), "Variable not in scope: c")]
1498+ )
1499+ ]
1500+
1501+cppTests :: TestTree
1502+cppTests =
1503+ testGroup "cpp"
1504+ [ testCase "cpp-error" $ do
1505+ let content =
1506+ T.unlines
1507+ [ "{-# LANGUAGE CPP #-}",
1508+ "module Testing where",
1509+ "#ifdef FOO",
1510+ "foo = 42"
1511+ ]
1512+ -- The error locations differ depending on which C-preprocessor is used.
1513+ -- Some give the column number and others don't (hence -1). Assert either
1514+ -- of them.
1515+ (run $ expectError content (2, -1))
1516+ `catch` ( \e -> do
1517+ let _ = e :: HUnitFailure
1518+ run $ expectError content (2, 1)
1519+ )
1520+ , testSessionWait "cpp-ghcide" $ do
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1522+ ["{-# LANGUAGE CPP #-}"
1523+ ,"main ="
1524+ ,"#ifdef __GHCIDE__"
1525+ ," worked"
1526+ ,"#else"
1527+ ," failed"
1528+ ,"#endif"
1529+ ]
1530+ expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1531+ ]
1532+ where
1533+ expectError :: T.Text -> Cursor -> Session ()
1534+ expectError content cursor = do
1535+ _ <- createDoc "Testing.hs" "haskell" content
1536+ expectDiagnostics
1537+ [ ( "Testing.hs",
1538+ [(DsError, cursor, "error: unterminated")]
1539+ )
1540+ ]
1541+ expectNoMoreDiagnostics 0.5
1542+
1543+preprocessorTests :: TestTree
1544+preprocessorTests = testSessionWait "preprocessor" $ do
1545+ let content =
1546+ T.unlines
1547+ [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
1548+ , "module Testing where"
1549+ , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1550+ ]
1551+ _ <- createDoc "Testing.hs" "haskell" content
1552+ expectDiagnostics
1553+ [ ( "Testing.hs",
1554+ [(DsError, (2, 8), "Variable not in scope: z")]
1555+ )
1556+ ]
1557+
1558+
1559+safeTests :: TestTree
1560+safeTests =
1561+ testGroup
1562+ "SafeHaskell"
1563+ [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564+ testSessionWait "load" $ do
1565+ let sourceA =
1566+ T.unlines
1567+ ["{-# LANGUAGE Trustworthy #-}"
1568+ ,"module A where"
1569+ ,"import System.IO.Unsafe"
1570+ ,"import System.IO"
1571+ ,"trustWorthyId :: a -> a"
1572+ ,"trustWorthyId i = unsafePerformIO $ do"
1573+ ," putStrLn \"I'm safe\""
1574+ ," return i"]
1575+ sourceB =
1576+ T.unlines
1577+ ["{-# LANGUAGE Safe #-}"
1578+ ,"module B where"
1579+ ,"import A"
1580+ ,"safeId :: a -> a"
1581+ ,"safeId = trustWorthyId"
1582+ ]
1583+
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
1586+ expectNoMoreDiagnostics 1 ]
1587+
1588+thTests :: TestTree
1589+thTests =
1590+ testGroup
1591+ "TemplateHaskell"
1592+ [ -- Test for https://github.com/digital-asset/ghcide/pull/212
1593+ testSessionWait "load" $ do
1594+ let sourceA =
1595+ T.unlines
1596+ [ "{-# LANGUAGE PackageImports #-}",
1597+ "{-# LANGUAGE TemplateHaskell #-}",
1598+ "module A where",
1599+ "import \"template-haskell\" Language.Haskell.TH",
1600+ "a :: Integer",
1601+ "a = $(litE $ IntegerL 3)"
1602+ ]
1603+ sourceB =
1604+ T.unlines
1605+ [ "{-# LANGUAGE PackageImports #-}",
1606+ "{-# LANGUAGE TemplateHaskell #-}",
1607+ "module B where",
1608+ "import A",
1609+ "import \"template-haskell\" Language.Haskell.TH",
1610+ "b :: Integer",
1611+ "b = $(litE $ IntegerL $ a) + n"
1612+ ]
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1615+ expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616+ , testSessionWait "newtype-closure" $ do
1617+ let sourceA =
1618+ T.unlines
1619+ [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620+ ,"{-# LANGUAGE TemplateHaskell #-}"
1621+ ,"module A (a) where"
1622+ ,"import Data.Data"
1623+ ,"import Language.Haskell.TH"
1624+ ,"newtype A = A () deriving (Data)"
1625+ ,"a :: ExpQ"
1626+ ,"a = [| 0 |]"]
1627+ let sourceB =
1628+ T.unlines
1629+ [ "{-# LANGUAGE TemplateHaskell #-}"
1630+ ,"module B where"
1631+ ,"import A"
1632+ ,"b :: Int"
1633+ ,"b = $( a )" ]
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1636+ return ()
1637+ ]
1638+
1639+completionTests :: TestTree
1640+completionTests
1641+ = testGroup "completion"
1642+ [ testSessionWait "variable" $ do
1643+ let source = T.unlines ["module A where", "f = hea"]
1644+ docId <- createDoc "A.hs" "haskell" source
1645+ compls <- getCompletions docId (Position 1 7)
1646+ liftIO $ map dropDocs compls @?=
1647+ [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1648+ let [CompletionItem { _documentation = headDocs}] = compls
1649+ checkDocText "head" headDocs [ "Defined in 'Prelude'"
1650+#if MIN_GHC_API_VERSION(8,6,5)
1651+ , "Extract the first element of a list"
1652+#endif
1653+ ]
1654+ , testSessionWait "constructor" $ do
1655+ let source = T.unlines ["module A where", "f = Tru"]
1656+ docId <- createDoc "A.hs" "haskell" source
1657+ compls <- getCompletions docId (Position 1 7)
1658+ liftIO $ map dropDocs compls @?=
1659+ [ complItem "True" (Just CiConstructor) (Just "Bool")
1660+#if MIN_GHC_API_VERSION(8,6,0)
1661+ , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1662+#else
1663+ , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1664+#endif
1665+ ]
1666+ , testSessionWait "type" $ do
1667+ let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668+ docId <- createDoc "A.hs" "haskell" source
1669+ expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1670+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1671+ compls <- getCompletions docId (Position 2 7)
1672+ liftIO $ map dropDocs compls @?=
1673+ [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")
1674+ , complItem "Bool" (Just CiStruct) (Just "*") ]
1675+ let [ CompletionItem { _documentation = boundedDocs},
1676+ CompletionItem { _documentation = boolDocs } ] = compls
1677+ checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1678+#if MIN_GHC_API_VERSION(8,6,5)
1679+ , "name the upper and lower limits"
1680+#endif
1681+ ]
1682+ checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1683+ , testSessionWait "qualified" $ do
1684+ let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685+ docId <- createDoc "A.hs" "haskell" source
1686+ expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1687+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1688+ compls <- getCompletions docId (Position 2 15)
1689+ liftIO $ map dropDocs compls @?=
1690+ [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1691+ let [CompletionItem { _documentation = headDocs}] = compls
1692+ checkDocText "head" headDocs [ "Defined in 'Prelude'"
1693+#if MIN_GHC_API_VERSION(8,6,5)
1694+ , "Extract the first element of a list"
1695+#endif
1696+ ]
1697+ , testSessionWait "keyword" $ do
1698+ let source = T.unlines ["module A where", "f = newty"]
1699+ docId <- createDoc "A.hs" "haskell" source
1700+ compls <- getCompletions docId (Position 1 9)
1701+ liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1706+ , "f = f"
1707+ ]
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710+ changeDoc docId
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
1714+ , "f = f"
1715+ , "g :: Intege"
1716+ ]
1717+ ]
1718+ -- At this point the module parses but does not typecheck.
1719+ -- This should be sufficient to detect that we are in a
1720+ -- type context and only show the completion to the type.
1721+ compls <- getCompletions docId (Position 3 11)
1722+ liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1723+ ]
1724+ where
1725+ dropDocs :: CompletionItem -> CompletionItem
1726+ dropDocs ci = ci { _documentation = Nothing }
1727+ complItem label kind ty = CompletionItem
1728+ { _label = label
1729+ , _kind = kind
1730+ , _tags = List []
1731+ , _detail = (":: " <>) <$> ty
1732+ , _documentation = Nothing
1733+ , _deprecated = Nothing
1734+ , _preselect = Nothing
1735+ , _sortText = Nothing
1736+ , _filterText = Nothing
1737+ , _insertText = Nothing
1738+ , _insertTextFormat = Just PlainText
1739+ , _textEdit = Nothing
1740+ , _additionalTextEdits = Nothing
1741+ , _commitCharacters = Nothing
1742+ , _command = Nothing
1743+ , _xdata = Nothing
1744+ }
1745+ keywordItem label = CompletionItem
1746+ { _label = label
1747+ , _kind = Just CiKeyword
1748+ , _tags = List []
1749+ , _detail = Nothing
1750+ , _documentation = Nothing
1751+ , _deprecated = Nothing
1752+ , _preselect = Nothing
1753+ , _sortText = Nothing
1754+ , _filterText = Nothing
1755+ , _insertText = Nothing
1756+ , _insertTextFormat = Nothing
1757+ , _textEdit = Nothing
1758+ , _additionalTextEdits = Nothing
1759+ , _commitCharacters = Nothing
1760+ , _command = Nothing
1761+ , _xdata = Nothing
1762+ }
1763+ getDocText (CompletionDocString s) = s
1764+ getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1765+ checkDocText thing Nothing _
1766+ = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"
1767+ checkDocText thing (Just doc) items
1768+ = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $
1769+ all (`T.isInfixOf` getDocText doc) items
1770+
1771+outlineTests :: TestTree
1772+outlineTests = testGroup
1773+ "outline"
1774+ [ testSessionWait "type class" $ do
1775+ let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776+ docId <- createDoc "A.hs" "haskell" source
1777+ symbols <- getDocumentSymbols docId
1778+ liftIO $ symbols @?= Left
1779+ [ moduleSymbol
1780+ "A"
1781+ (R 0 7 0 8)
1782+ [ classSymbol "A a"
1783+ (R 1 0 1 30)
1784+ [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
1785+ ]
1786+ ]
1787+ , testSessionWait "type class instance " $ do
1788+ let source = T.unlines ["class A a where", "instance A () where"]
1789+ docId <- createDoc "A.hs" "haskell" source
1790+ symbols <- getDocumentSymbols docId
1791+ liftIO $ symbols @?= Left
1792+ [ classSymbol "A a" (R 0 0 0 15) []
1793+ , docSymbol "A ()" SkInterface (R 1 0 1 19)
1794+ ]
1795+ , testSessionWait "type family" $ do
1796+ let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797+ docId <- createDoc "A.hs" "haskell" source
1798+ symbols <- getDocumentSymbols docId
1799+ liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1800+ , testSessionWait "type family instance " $ do
1801+ let source = T.unlines
1802+ [ "{-# language TypeFamilies #-}"
1803+ , "type family A a"
1804+ , "type instance A () = ()"
1805+ ]
1806+ docId <- createDoc "A.hs" "haskell" source
1807+ symbols <- getDocumentSymbols docId
1808+ liftIO $ symbols @?= Left
1809+ [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1810+ , docSymbol "A ()" SkInterface (R 2 0 2 23)
1811+ ]
1812+ , testSessionWait "data family" $ do
1813+ let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814+ docId <- createDoc "A.hs" "haskell" source
1815+ symbols <- getDocumentSymbols docId
1816+ liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1817+ , testSessionWait "data family instance " $ do
1818+ let source = T.unlines
1819+ [ "{-# language TypeFamilies #-}"
1820+ , "data family A a"
1821+ , "data instance A () = A ()"
1822+ ]
1823+ docId <- createDoc "A.hs" "haskell" source
1824+ symbols <- getDocumentSymbols docId
1825+ liftIO $ symbols @?= Left
1826+ [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1827+ , docSymbol "A ()" SkInterface (R 2 0 2 25)
1828+ ]
1829+ , testSessionWait "constant" $ do
1830+ let source = T.unlines ["a = ()"]
1831+ docId <- createDoc "A.hs" "haskell" source
1832+ symbols <- getDocumentSymbols docId
1833+ liftIO $ symbols @?= Left
1834+ [docSymbol "a" SkFunction (R 0 0 0 6)]
1835+ , testSessionWait "pattern" $ do
1836+ let source = T.unlines ["Just foo = Just 21"]
1837+ docId <- createDoc "A.hs" "haskell" source
1838+ symbols <- getDocumentSymbols docId
1839+ liftIO $ symbols @?= Left
1840+ [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1841+ , testSessionWait "pattern with type signature" $ do
1842+ let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843+ docId <- createDoc "A.hs" "haskell" source
1844+ symbols <- getDocumentSymbols docId
1845+ liftIO $ symbols @?= Left
1846+ [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1847+ , testSessionWait "function" $ do
1848+ let source = T.unlines ["a x = ()"]
1849+ docId <- createDoc "A.hs" "haskell" source
1850+ symbols <- getDocumentSymbols docId
1851+ liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1852+ , testSessionWait "type synonym" $ do
1853+ let source = T.unlines ["type A = Bool"]
1854+ docId <- createDoc "A.hs" "haskell" source
1855+ symbols <- getDocumentSymbols docId
1856+ liftIO $ symbols @?= Left
1857+ [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1858+ , testSessionWait "datatype" $ do
1859+ let source = T.unlines ["data A = C"]
1860+ docId <- createDoc "A.hs" "haskell" source
1861+ symbols <- getDocumentSymbols docId
1862+ liftIO $ symbols @?= Left
1863+ [ docSymbolWithChildren "A"
1864+ SkStruct
1865+ (R 0 0 0 10)
1866+ [docSymbol "C" SkConstructor (R 0 9 0 10)]
1867+ ]
1868+ , testSessionWait "record fields" $ do
1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870+ docId <- createDoc "A.hs" "haskell" source
1871+ symbols <- getDocumentSymbols docId
1872+ liftIO $ symbols @=? Left
1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875+ [ docSymbol "x" SkField (R 1 2 1 3)
1876+ , docSymbol "y" SkField (R 2 4 2 5)
1877+ ]
1878+ ]
1879+ ]
1880+ , testSessionWait "import" $ do
1881+ let source = T.unlines ["import Data.Maybe"]
1882+ docId <- createDoc "A.hs" "haskell" source
1883+ symbols <- getDocumentSymbols docId
1884+ liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1886+ SkModule
1887+ (R 0 0 0 17)
1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1889+ ]
1890+ ]
1891+ , testSessionWait "multiple import" $ do
1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893+ docId <- createDoc "A.hs" "haskell" source
1894+ symbols <- getDocumentSymbols docId
1895+ liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1897+ SkModule
1898+ (R 1 0 3 24)
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1901+ ]
1902+ ]
1903+ , testSessionWait "foreign import" $ do
1904+ let source = T.unlines
1905+ [ "{-# language ForeignFunctionInterface #-}"
1906+ , "foreign import ccall \"a\" a :: Int"
1907+ ]
1908+ docId <- createDoc "A.hs" "haskell" source
1909+ symbols <- getDocumentSymbols docId
1910+ liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1911+ , testSessionWait "foreign export" $ do
1912+ let source = T.unlines
1913+ [ "{-# language ForeignFunctionInterface #-}"
1914+ , "foreign export ccall odd :: Int -> Bool"
1915+ ]
1916+ docId <- createDoc "A.hs" "haskell" source
1917+ symbols <- getDocumentSymbols docId
1918+ liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
5851919 ]
1920+ where
1921+ docSymbol name kind loc =
1922+ DocumentSymbol name Nothing kind Nothing loc loc Nothing
1923+ docSymbol' name kind loc selectionLoc =
1924+ DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing
1925+ docSymbolD name detail kind loc =
1926+ DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1927+ docSymbolWithChildren name kind loc cc =
1928+ DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1929+ docSymbolWithChildren' name kind loc selectionLoc cc =
1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
1931+ moduleSymbol name loc cc = DocumentSymbol name
1932+ Nothing
1933+ SkFile
1934+ Nothing
1935+ (R 0 0 maxBound 0)
1936+ loc
1937+ (Just $ List cc)
1938+ classSymbol name loc cc = DocumentSymbol name
1939+ (Just "class")
1940+ SkClass
1941+ Nothing
1942+ loc
1943+ loc
1944+ (Just $ List cc)
1945+
1946+pattern R :: Int -> Int -> Int -> Int -> Range
1947+pattern R x y x' y' = Range (Position x y) (Position x' y')
1948+
1949+xfail :: TestTree -> String -> TestTree
1950+xfail = flip expectFailBecause
1951+
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1955+#else
1956+xfail8101 t _ = t
1957+#endif
1958+
1959+data Expect
1960+ = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1962+-- | ExpectDefRange Range -- Only gotoDef should report this range
1963+ | ExpectHoverRange Range -- Only hover should report this range
1964+ | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1965+ | ExpectExternFail -- definition lookup in other file expected to fail
1966+ | ExpectNoDefinitions
1967+ | ExpectNoHover
1968+-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1969+ deriving Eq
1970+
1971+mkR :: Int -> Int -> Int -> Int -> Expect
1972+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1973+
1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976+
1977+haddockTests :: TestTree
1978+haddockTests
1979+ = testGroup "haddock"
1980+ [ testCase "Num" $ checkHaddock
1981+ (unlines
1982+ [ "However, '(+)' and '(*)' are"
1983+ , "customarily expected to define a ring and have the following properties:"
1984+ , ""
1985+ , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986+ , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987+ , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1988+ ]
1989+ )
1990+ (unlines
1991+ [ ""
1992+ , ""
1993+ , "However, `(+)` and `(*)` are"
1994+ , "customarily expected to define a ring and have the following properties: "
1995+ , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996+ , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997+ , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
1998+ ]
1999+ )
2000+ , testCase "unsafePerformIO" $ checkHaddock
2001+ (unlines
2002+ [ "may require"
2003+ , "different precautions:"
2004+ , ""
2005+ , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006+ , " that calls 'unsafePerformIO'. If the call is inlined,"
2007+ , " the I\\/O may be performed more than once."
2008+ , ""
2009+ , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010+ , " elimination being performed on the module."
2011+ , ""
2012+ ]
2013+ )
2014+ (unlines
2015+ [ ""
2016+ , ""
2017+ , "may require"
2018+ , "different precautions: "
2019+ , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020+ , " that calls `unsafePerformIO` . If the call is inlined,"
2021+ , " the I/O may be performed more than once."
2022+ , ""
2023+ , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024+ , " elimination being performed on the module."
2025+ , ""
2026+ ]
2027+ )
2028+ ]
2029+ where
2030+ checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2031+
2032+cradleTests :: TestTree
2033+cradleTests = testGroup "cradle"
2034+ [testGroup "dependencies" [sessionDepsArePickedUp]
2035+ ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2037+ ]
2038+
2039+loadCradleOnlyonce :: TestTree
2040+loadCradleOnlyonce = testGroup "load cradle only once"
2041+ [ testSession' "implicit" implicit
2042+ , testSession' "direct" direct
2043+ ]
2044+ where
2045+ direct dir = do
2046+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047+ "cradle: {direct: {arguments: []}}"
2048+ test dir
2049+ implicit dir = test dir
2050+ test _dir = do
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053+ liftIO $ length msgs @?= 1
2054+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056+ liftIO $ length msgs @?= 0
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059+ liftIO $ length msgs @?= 0
2060+
2061+
2062+dependentFileTest :: TestTree
2063+dependentFileTest = testGroup "addDependentFile"
2064+ [testGroup "file-changed" [testSession' "test" test]
2065+ ]
2066+ where
2067+ test dir = do
2068+ -- If the file contains B then no type error
2069+ -- otherwise type error
2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071+ let fooContent = T.unlines
2072+ [ "{-# LANGUAGE TemplateHaskell #-}"
2073+ , "module Foo where"
2074+ , "import Language.Haskell.TH.Syntax"
2075+ , "foo :: Int"
2076+ , "foo = 1 + $(do"
2077+ , " qAddDependentFile \"dep-file.txt\""
2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"
2079+ , " if f == \"B\" then [| 1 |] else lift f)"
2080+ ]
2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]
2082+ _ <-createDoc "Foo.hs" "haskell" fooContent
2083+ doc <- createDoc "Baz.hs" "haskell" bazContent
2084+ expectDiagnostics
2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086+ -- Now modify the dependent file
2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088+ let change = TextDocumentContentChangeEvent
2089+ { _range = Just (Range (Position 2 0) (Position 2 6))
2090+ , _rangeLength = Nothing
2091+ , _text = "f = ()"
2092+ }
2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well
2094+ changeDoc doc [change]
2095+ expectDiagnostics [("Foo.hs", [])]
2096+
2097+
2098+cradleLoadedMessage :: Session FromServerMessage
2099+cradleLoadedMessage = satisfy $ \case
2100+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2101+ _ -> False
2102+
2103+cradleLoadedMethod :: T.Text
2104+cradleLoadedMethod = "ghcide/cradle/loaded"
2105+
2106+-- Stack sets this which trips up cabal in the multi-component tests.
2107+-- However, our plugin tests rely on those env vars so we unset it locally.
2108+withoutStackEnv :: IO a -> IO a
2109+withoutStackEnv s =
2110+ bracket
2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2113+ (const s)
2114+ where vars =
2115+ [ "GHC_PACKAGE_PATH"
2116+ , "GHC_ENVIRONMENT"
2117+ , "HASKELL_DIST_DIR"
2118+ , "HASKELL_PACKAGE_SANDBOX"
2119+ , "HASKELL_PACKAGE_SANDBOXES"
2120+ ]
2121+ restore var Nothing = unsetEnv var
2122+ restore var (Just val) = setEnv var val True
2123+
2124+simpleMultiTest :: TestTree
2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126+ let aPath = dir </> "a/A.hs"
2127+ bPath = dir </> "b/B.hs"
2128+ aSource <- liftIO $ readFileUtf8 aPath
2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130+ expectNoMoreDiagnostics 0.5
2131+ bSource <- liftIO $ readFileUtf8 bPath
2132+ bdoc <- createDoc bPath "haskell" bSource
2133+ expectNoMoreDiagnostics 0.5
2134+ locs <- getDefinitions bdoc (Position 2 7)
2135+ let fooL = mkL adoc 2 0 2 3
2136+ checkDefs locs (pure [fooL])
2137+ expectNoMoreDiagnostics 0.5
2138+
2139+-- Like simpleMultiTest but open the files in the other order
2140+simpleMultiTest2 :: TestTree
2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142+ let aPath = dir </> "a/A.hs"
2143+ bPath = dir </> "b/B.hs"
2144+ bSource <- liftIO $ readFileUtf8 bPath
2145+ bdoc <- createDoc bPath "haskell" bSource
2146+ expectNoMoreDiagnostics 5
2147+ aSource <- liftIO $ readFileUtf8 aPath
2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149+ -- Need to have some delay here or the test fails
2150+ expectNoMoreDiagnostics 5
2151+ locs <- getDefinitions bdoc (Position 2 7)
2152+ let fooL = mkL adoc 2 0 2 3
2153+ checkDefs locs (pure [fooL])
2154+ expectNoMoreDiagnostics 0.5
2155+
2156+sessionDepsArePickedUp :: TestTree
2157+sessionDepsArePickedUp = testSession'
2158+ "session-deps-are-picked-up"
2159+ $ \dir -> do
2160+ liftIO $
2161+ writeFileUTF8
2162+ (dir </> "hie.yaml")
2163+ "cradle: {direct: {arguments: []}}"
2164+ -- Open without OverloadedStrings and expect an error.
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
2166+ expectDiagnostics
2167+ [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168+ -- Update hie.yaml to enable OverloadedStrings.
2169+ liftIO $
2170+ writeFileUTF8
2171+ (dir </> "hie.yaml")
2172+ "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173+ -- Send change event.
2174+ let change =
2175+ TextDocumentContentChangeEvent
2176+ { _range = Just (Range (Position 4 0) (Position 4 0)),
2177+ _rangeLength = Nothing,
2178+ _text = "\n"
2179+ }
2180+ changeDoc doc [change]
2181+ -- Now no errors.
2182+ expectDiagnostics [("Foo.hs", [])]
2183+ where
2184+ fooContent =
2185+ T.unlines
2186+ [ "module Foo where",
2187+ "import Data.Text",
2188+ "foo :: Text",
2189+ "foo = \"hello\""
2190+ ]
2191+
5862192
5872193----------------------------------------------------------------------
5882194-- Utils
5892195
5902196
5912197testSession :: String -> Session () -> TestTree
592−testSession name =
593− testCase name . run .
2198+testSession name = testCase name . run
2199+
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
2203+testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204+testSession' name = testCase name . run'
2205+
2206+testSessionWait :: String -> Session () -> TestTree
2207+testSessionWait name = testSession name .
5942208 -- Check that any diagnostics produced were already consumed by the test case.
5952209 --
5962210 -- If in future we add test cases where we don't care about checking the diagnostics,
@@ -599,22 +2213,284 @@ testSession name =
5992213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
6002214 ( >> expectNoMoreDiagnostics 0.5)
6012215
602−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
603−pickActionWithTitle title actions = head
604− [ action
605− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
606− , title == actionTitle ]
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
2217+pickActionWithTitle title actions = do
2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219+ return $ head matches
2220+ where
2221+ titles =
2222+ [ actionTitle
2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2224+ ]
2225+ matches =
2226+ [ action
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2228+ , title == actionTitle
2229+ ]
2230+
2231+mkRange :: Int -> Int -> Int -> Int -> Range
2232+mkRange a b c d = Range (Position a b) (Position c d)
6072233
6082234run :: Session a -> IO a
609−run s = withTempDir $ \dir -> do
2235+run s = withTempDir $ \dir -> runInDir dir s
2236+
2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239+ copyTestDataFiles dir prefix
2240+ runInDir dir (s dir)
2241+
2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243+copyTestDataFiles dir prefix = do
2244+ -- Copy all the test data files to the temporary workspace
2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246+ for_ testDataFiles $ \f -> do
2247+ createDirectoryIfMissing True $ dir </> takeDirectory f
2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)
2249+
2250+run' :: (FilePath -> Session a) -> IO a
2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)
2252+
2253+runInDir :: FilePath -> Session a -> IO a
2254+runInDir dir s = do
6102255 ghcideExe <- locateGhcideExecutable
611− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2256+
2257+ -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2258+ -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2259+ createDirectoryIfMissing True $ dir ++ "/Data"
2260+
2261+
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
6122263 -- HIE calls getXgdDirectory which assumes that HOME is set.
6132264 -- Only sets HOME if it wasn't already set.
6142265 setEnv "HOME" "/homeless-shelter" False
615− runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2266+ let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
2267+ runSessionWithConfig conf cmd lspTestCaps dir s
6162268 where
6172269 conf = defaultConfig
618− -- If you uncomment this you can see all messages
2270+ -- If you uncomment this you can see all logging
6192271 -- which can be quite useful for debugging.
620− -- { logMessages = True, logColor = False, logStdErr = True }
2272+ -- { logStdErr = True, logColor = False }
2273+ -- If you really want to, you can also see all messages
2274+ -- { logMessages = True, logColor = False }
2275+
2276+openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2277+openTestDataDoc path = do
2278+ source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279+ createDoc path "haskell" source
2280+
2281+findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282+findCodeActions doc range expectedTitles = do
2283+ actions <- getCodeActions doc range
2284+ let matches = sequence
2285+ [ listToMaybe
2286+ [ action
2287+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288+ , actionTitle == expectedTitle ]
2289+ | expectedTitle <- expectedTitles]
2290+ let msg = show
2291+ [ actionTitle
2292+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2293+ ]
2294+ ++ " is not a superset of "
2295+ ++ show expectedTitles
2296+ liftIO $ case matches of
2297+ Nothing -> assertFailure msg
2298+ Just _ -> pure ()
2299+ return (fromJust matches)
2300+
2301+findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302+findCodeAction doc range t = head <$> findCodeActions doc range [t]
2303+
2304+unitTests :: TestTree
2305+unitTests = do
2306+ testGroup "Unit"
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
2308+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309+ , testCase "empty file path works using toNormalizedFilePath'" $
2310+ uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311+ , testCase "empty path URI" $ do
2312+ Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313+ uriScheme @?= "file:"
2314+ uriPath @?= ""
2315+ , testCase "from empty path URI" $ do
2316+ let uri = Uri "file://"
2317+ uriToFilePath' uri @?= Just ""
2318+ ]
2319+
2320+positionMappingTests :: TestTree
2321+positionMappingTests =
2322+ testGroup "position mapping"
2323+ [ testGroup "toCurrent"
2324+ [ testCase "before" $
2325+ toCurrent
2326+ (Range (Position 0 1) (Position 0 3))
2327+ "ab"
2328+ (Position 0 0) @?= Just (Position 0 0)
2329+ , testCase "after, same line, same length" $
2330+ toCurrent
2331+ (Range (Position 0 1) (Position 0 3))
2332+ "ab"
2333+ (Position 0 3) @?= Just (Position 0 3)
2334+ , testCase "after, same line, increased length" $
2335+ toCurrent
2336+ (Range (Position 0 1) (Position 0 3))
2337+ "abc"
2338+ (Position 0 3) @?= Just (Position 0 4)
2339+ , testCase "after, same line, decreased length" $
2340+ toCurrent
2341+ (Range (Position 0 1) (Position 0 3))
2342+ "a"
2343+ (Position 0 3) @?= Just (Position 0 2)
2344+ , testCase "after, next line, no newline" $
2345+ toCurrent
2346+ (Range (Position 0 1) (Position 0 3))
2347+ "abc"
2348+ (Position 1 3) @?= Just (Position 1 3)
2349+ , testCase "after, next line, newline" $
2350+ toCurrent
2351+ (Range (Position 0 1) (Position 0 3))
2352+ "abc\ndef"
2353+ (Position 1 0) @?= Just (Position 2 0)
2354+ , testCase "after, same line, newline" $
2355+ toCurrent
2356+ (Range (Position 0 1) (Position 0 3))
2357+ "abc\nd"
2358+ (Position 0 4) @?= Just (Position 1 2)
2359+ , testCase "after, same line, newline + newline at end" $
2360+ toCurrent
2361+ (Range (Position 0 1) (Position 0 3))
2362+ "abc\nd\n"
2363+ (Position 0 4) @?= Just (Position 2 1)
2364+ , testCase "after, same line, newline + newline at end" $
2365+ toCurrent
2366+ (Range (Position 0 1) (Position 0 1))
2367+ "abc"
2368+ (Position 0 1) @?= Just (Position 0 4)
2369+ ]
2370+ , testGroup "fromCurrent"
2371+ [ testCase "before" $
2372+ fromCurrent
2373+ (Range (Position 0 1) (Position 0 3))
2374+ "ab"
2375+ (Position 0 0) @?= Just (Position 0 0)
2376+ , testCase "after, same line, same length" $
2377+ fromCurrent
2378+ (Range (Position 0 1) (Position 0 3))
2379+ "ab"
2380+ (Position 0 3) @?= Just (Position 0 3)
2381+ , testCase "after, same line, increased length" $
2382+ fromCurrent
2383+ (Range (Position 0 1) (Position 0 3))
2384+ "abc"
2385+ (Position 0 4) @?= Just (Position 0 3)
2386+ , testCase "after, same line, decreased length" $
2387+ fromCurrent
2388+ (Range (Position 0 1) (Position 0 3))
2389+ "a"
2390+ (Position 0 2) @?= Just (Position 0 3)
2391+ , testCase "after, next line, no newline" $
2392+ fromCurrent
2393+ (Range (Position 0 1) (Position 0 3))
2394+ "abc"
2395+ (Position 1 3) @?= Just (Position 1 3)
2396+ , testCase "after, next line, newline" $
2397+ fromCurrent
2398+ (Range (Position 0 1) (Position 0 3))
2399+ "abc\ndef"
2400+ (Position 2 0) @?= Just (Position 1 0)
2401+ , testCase "after, same line, newline" $
2402+ fromCurrent
2403+ (Range (Position 0 1) (Position 0 3))
2404+ "abc\nd"
2405+ (Position 1 2) @?= Just (Position 0 4)
2406+ , testCase "after, same line, newline + newline at end" $
2407+ fromCurrent
2408+ (Range (Position 0 1) (Position 0 3))
2409+ "abc\nd\n"
2410+ (Position 2 1) @?= Just (Position 0 4)
2411+ , testCase "after, same line, newline + newline at end" $
2412+ fromCurrent
2413+ (Range (Position 0 1) (Position 0 1))
2414+ "abc"
2415+ (Position 0 4) @?= Just (Position 0 1)
2416+ ]
2417+ , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
2418+ [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
2419+ -- Note that it is important to use suchThatMap on all values at once
2420+ -- instead of only using it on the position. Otherwise you can get
2421+ -- into situations where there is no position that can be mapped back
2422+ -- for the edit which will result in QuickCheck looping forever.
2423+ let gen = do
2424+ rope <- genRope
2425+ range <- genRange rope
2426+ PrintableText replacement <- arbitrary
2427+ oldPos <- genPosition rope
2428+ pure (range, replacement, oldPos)
2429+ forAll
2430+ (suchThatMap gen
2431+ (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
2432+ \(range, replacement, oldPos, newPos) ->
2433+ fromCurrent range replacement newPos === Just oldPos
2434+ , testProperty "toCurrent r t <=< fromCurrent r t" $ do
2435+ let gen = do
2436+ rope <- genRope
2437+ range <- genRange rope
2438+ PrintableText replacement <- arbitrary
2439+ let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
2440+ newPos <- genPosition newRope
2441+ pure (range, replacement, newPos)
2442+ forAll
2443+ (suchThatMap gen
2444+ (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445+ \(range, replacement, newPos, oldPos) ->
2446+ toCurrent range replacement oldPos === Just newPos
2447+ ]
2448+ ]
2449+
2450+newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2451+ deriving Show
2452+
2453+instance Arbitrary PrintableText where
2454+ arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2455+
2456+
2457+genRope :: Gen Rope
2458+genRope = Rope.fromText . getPrintableText <$> arbitrary
2459+
2460+genPosition :: Rope -> Gen Position
2461+genPosition r = do
2462+ row <- choose (0, max 0 $ rows - 1)
2463+ let columns = Rope.columns (nthLine row r)
2464+ column <- choose (0, max 0 $ columns - 1)
2465+ pure $ Position row column
2466+ where rows = Rope.rows r
2467+
2468+genRange :: Rope -> Gen Range
2469+genRange r = do
2470+ startPos@(Position startLine startColumn) <- genPosition r
2471+ let maxLineDiff = max 0 $ rows - 1 - startLine
2472+ endLine <- choose (startLine, startLine + maxLineDiff)
2473+ let columns = Rope.columns (nthLine endLine r)
2474+ endColumn <-
2475+ if startLine == endLine
2476+ then choose (startColumn, columns)
2477+ else choose (0, max 0 $ columns - 1)
2478+ pure $ Range startPos (Position endLine endColumn)
2479+ where rows = Rope.rows r
2480+
2481+-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482+nthLine :: Int -> Rope -> Rope
2483+nthLine i r
2484+ | i < 0 = error $ "Negative line number: " <> show i
2485+ | i == 0 && Rope.rows r == 0 = r
2486+ | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2487+ | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2488+
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490+getWatchedFilesSubscriptionsUntil = do
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2492+ return
2493+ [ args
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2496+ ]