@@ -1,158 +1,33 @@
1−-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE DuplicateRecordFields #-}
6−{-# LANGUAGE PatternSynonyms #-}
8−#include "ghc-api-version.h"
10module Main (main) where
5module Main (main) where
12−import Control.Applicative.Combinators
7+import Control.Monad (void)
13−import Control.Exception (bracket, catch)
14−import qualified Control.Lens as Lens
16−import Control.Monad.IO.Class (liftIO)
17−import Data.Aeson (FromJSON, Value)
19−import Data.List.Extra
20−import Data.Rope.UTF16 (Rope)
21−import qualified Data.Rope.UTF16 as Rope
22−import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
23−import Development.IDE.GHC.Util
24import qualified Data.Text as T
8import qualified Data.Text as T
26−import Development.IDE.Spans.Common
27import Development.IDE.Test
9import Development.IDE.Test
28−import Development.IDE.Test.Runfiles
29−import Development.IDE.Types.Location
30−import Development.Shake (getDirectoryFilesIO)
31import Language.Haskell.LSP.Test
10import Language.Haskell.LSP.Test
32−import Language.Haskell.LSP.Messages
33import Language.Haskell.LSP.Types
11import Language.Haskell.LSP.Types
34−import Language.Haskell.LSP.Types.Capabilities
35−import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
36−import Language.Haskell.LSP.VFS (applyChange)
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
12+import System.Environment.Blank (setEnv)
39import System.FilePath
13import System.FilePath
40import System.IO.Extra
14import System.IO.Extra
41−import System.Directory
42−import Test.QuickCheck
43−import Test.QuickCheck.Instances ()
44import Test.Tasty
15import Test.Tasty
45−import Test.Tasty.ExpectedFailure
46−import Test.Tasty.Ingredients.Rerun
47import Test.Tasty.HUnit
16import Test.Tasty.HUnit
48−import Test.Tasty.QuickCheck
51−main :: IO ()
18+import DA.Bazel.Runfiles
53− -- We mess with env vars so run single-threaded.
54− setEnv "TASTY_NUM_THREADS" "1" True
55− defaultMainWithRerun $ testGroup "HIE"
56− [ testSession "open close" $ do
57− doc <- createDoc "Testing.hs" "haskell" ""
58− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
59− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
62− , initializeResponseTests
69− , findDefinitionAndHoverTests
76− , positionMappingTests
82−initializeResponseTests :: TestTree
83−initializeResponseTests = withResource acquire release tests where
85− -- these tests document and monitor the evolution of the
86− -- capabilities announced by the server in the initialize
87− -- response. Currently the server advertises almost no capabilities
88− -- at all, in some cases failing to announce capabilities that it
89− -- actually does provide! Hopefully this will change ...
90− tests :: IO InitializeResponse -> TestTree
91− tests getInitializeResponse =
92− testGroup "initialize response capabilities"
93− [ chk " text doc sync" _textDocumentSync tds
94− , chk " hover" _hoverProvider (Just True)
95− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
96− , chk "NO signature help" _signatureHelpProvider Nothing
97− , chk " goto definition" _definitionProvider (Just True)
98− , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
99− , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
100− , chk "NO find references" _referencesProvider Nothing
101− , chk "NO doc highlight" _documentHighlightProvider Nothing
102− , chk " doc symbol" _documentSymbolProvider (Just True)
103− , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
104− , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
105− , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
106− , chk "NO doc formatting" _documentFormattingProvider Nothing
107− , chk "NO doc range formatting"
108− _documentRangeFormattingProvider Nothing
109− , chk "NO doc formatting on typing"
110− _documentOnTypeFormattingProvider Nothing
111− , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False)
112− , chk "NO doc link" _documentLinkProvider Nothing
113− , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114− , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116− , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
117− , chk "NO experimental" _experimental Nothing
120− tds = Just (TDSOptions (TextDocumentSyncOptions
121− { _openClose = Just True
122− , _change = Just TdSyncIncremental
123− , _willSave = Nothing
124− , _willSaveWaitUntil = Nothing
125− , _save = Just (SaveOptions {_includeText = Nothing})}))
127− chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
128− chk title getActual expected =
129− testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
131− che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132− che title getActual _expected = testCase title doTest
135− ir <- getInitializeResponse
136− let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137− True @=? T.isSuffixOf "typesignature.add" command
140− innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
142− innerCaps _ = error "this test only expects inner capabilities"
144− acquire :: IO InitializeResponse
145− acquire = run initializeResponse
147− release :: InitializeResponse -> IO ()
148− release = const $ pure ()
151−diagnosticTests :: TestTree
22+main = defaultMain $ testGroup "HIE"
152−diagnosticTests = testGroup "diagnostics"
23+ [ testSession "open close" $ do
24+ doc <- openDoc' "Testing.hs" "haskell" ""
25+ void (message :: Session ProgressStartNotification)
27+ void (message :: Session ProgressDoneNotification)
153− [ testSessionWait "fix syntax error" $ do
28+ , testSession "fix syntax error" $ do
154 let content = T.unlines [ "module Testing wher" ]
29 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
30+ doc <- openDoc' "Testing.hs" "haskell" content
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
31 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
157 let change = TextDocumentContentChangeEvent
32 let change = TextDocumentContentChangeEvent
158 { _range = Just (Range (Position 0 15) (Position 0 19))
33 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -161,11 +36,10 @@ diagnosticTests = testGroup "diagnostics"
162 changeDoc doc [change]
37 changeDoc doc [change]
163 expectDiagnostics [("Testing.hs", [])]
38 expectDiagnostics [("Testing.hs", [])]
164− , testSessionWait "introduce syntax error" $ do
39+ , testSession "introduce syntax error" $ do
165 let content = T.unlines [ "module Testing where" ]
40 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
41+ doc <- openDoc' "Testing.hs" "haskell" content
167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
42+ void (message :: Session ProgressStartNotification)
168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
169 let change = TextDocumentContentChangeEvent
43 let change = TextDocumentContentChangeEvent
170 { _range = Just (Range (Position 0 15) (Position 0 18))
44 { _range = Just (Range (Position 0 15) (Position 0 18))
171 , _rangeLength = Nothing
45 , _rangeLength = Nothing
@@ -173,2022 +47,8 @@ diagnosticTests = testGroup "diagnostics"
174 changeDoc doc [change]
48 changeDoc doc [change]
175 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
49 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
176− , testSessionWait "variable not in scope" $ do
177− let content = T.unlines
178− [ "module Testing where"
179− , "foo :: Int -> Int -> Int"
180− , "foo a b = a + ab"
181− , "bar :: Int -> Int -> Int"
182− , "bar a b = cd + b"
184− _ <- createDoc "Testing.hs" "haskell" content
187− , [ (DsError, (2, 14), "Variable not in scope: ab")
188− , (DsError, (4, 10), "Variable not in scope: cd")
192− , testSessionWait "type error" $ do
193− let content = T.unlines
194− [ "module Testing where"
195− , "foo :: Int -> String -> Int"
198− _ <- createDoc "Testing.hs" "haskell" content
201− , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
204− , testSessionWait "typed hole" $ do
205− let content = T.unlines
206− [ "module Testing where"
207− , "foo :: Int -> String"
210− _ <- createDoc "Testing.hs" "haskell" content
213− , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
217− , testGroup "deferral" $
218− let sourceA a = T.unlines
227− bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"
228− expectedDs aMessage =
229− [ ("A.hs", [(DsError, (2,4), aMessage)])
230− , ("B.hs", [(DsError, (3,4), bMessage)])]
231− deferralTest title binding msg = testSessionWait title $ do
232− _ <- createDoc "A.hs" "haskell" $ sourceA binding
233− _ <- createDoc "B.hs" "haskell" sourceB
234− expectDiagnostics $ expectedDs msg
236− [ deferralTest "type error" "True" "Couldn't match expected type"
237− , deferralTest "typed hole" "_" "Found hole"
238− , deferralTest "out of scope var" "unbound" "Variable not in scope"
241− , testSessionWait "remove required module" $ do
242− let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
244− let contentB = T.unlines
245− [ "module ModuleB where"
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
249− let change = TextDocumentContentChangeEvent
250− { _range = Just (Range (Position 0 0) (Position 0 20))
251− , _rangeLength = Nothing
254− changeDoc docA [change]
255− expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
256− , testSessionWait "add missing module" $ do
257− let contentB = T.unlines
258− [ "module ModuleB where"
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
262− expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263− let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
265− expectDiagnostics [("ModuleB.hs", [])]
266− , testSessionWait "add missing module (non workspace)" $ do
267− let contentB = T.unlines
268− [ "module ModuleB where"
271− _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272− expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273− let contentA = T.unlines [ "module ModuleA where" ]
274− _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275− expectDiagnostics [("/tmp/ModuleB.hs", [])]
276− , testSessionWait "cyclic module dependency" $ do
277− let contentA = T.unlines
278− [ "module ModuleA where"
281− let contentB = T.unlines
282− [ "module ModuleB where"
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
289− , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
292− , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
295− , testSessionWait "cyclic module dependency with hs-boot" $ do
296− let contentA = T.unlines
297− [ "module ModuleA where"
298− , "import {-# SOURCE #-} ModuleB"
300− let contentB = T.unlines
301− [ "module ModuleB where"
304− let contentBboot = T.unlines
305− [ "module ModuleB where"
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
310− expectDiagnostics []
311− , testSessionWait "correct reference used with hs-boot" $ do
312− let contentB = T.unlines
313− [ "module ModuleB where"
314− , "import {-# SOURCE #-} ModuleA"
316− let contentA = T.unlines
317− [ "module ModuleA where"
321− let contentAboot = T.unlines
322− [ "module ModuleA where"
324− let contentC = T.unlines
325− [ "module ModuleC where"
327− -- this reference will fail if it gets incorrectly
328− -- resolved to the hs-boot file
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
335− expectDiagnostics []
336− , testSessionWait "redundant import" $ do
337− let contentA = T.unlines ["module ModuleA where"]
338− let contentB = T.unlines
339− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
340− , "module ModuleB where"
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
347− , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
350− , testSessionWait "package imports" $ do
351− let thisDataListContent = T.unlines
352− [ "module Data.List where"
356− let mainContent = T.unlines
357− [ "{-# LANGUAGE PackageImports #-}"
358− , "module Main where"
359− , "import qualified \"this\" Data.List as ThisList"
360− , "import qualified \"base\" Data.List as BaseList"
361− , "useThis = ThisList.x"
362− , "useBase = BaseList.map"
363− , "wrong1 = ThisList.map"
364− , "wrong2 = BaseList.x"
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
370− , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
371− ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
375− , testSessionWait "unqualified warnings" $ do
376− let fooContent = T.unlines
377− [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
378− , "module Foo where"
379− , "foo :: Ord a => a -> Int"
382− _ <- createDoc "Foo.hs" "haskell" fooContent
385− -- The test is to make sure that warnings contain unqualified names
386− -- where appropriate. The warning should use an unqualified name 'Ord', not
387− -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
388− -- test this is fairly arbitrary.
389− , [(DsWarning, (2, 0), "Redundant constraint: Ord a")
393− , testSessionWait "lower-case drive" $ do
394− let aContent = T.unlines
395− [ "module A.A where"
398− bContent = T.unlines
399− [ "{-# OPTIONS_GHC -Wall #-}"
400− , "module A.B where"
401− , "import Data.List"
403− uriB <- getDocUri "A/B.hs"
404− Just pathB <- pure $ uriToFilePath uriB
406− let (drive, suffix) = splitDrive pathB
407− in filePathToUri (joinDrive (lower drive) suffix)
408− liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409− liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410− uriA <- getDocUri "A/A.hs"
411− Just pathA <- pure $ uriToFilePath uriA
413− let (drive, suffix) = splitDrive pathA
414− in filePathToUri (joinDrive (lower drive) suffix)
415− let itemA = TextDocumentItem uriA "haskell" 0 aContent
416− let a = TextDocumentIdentifier uriA
417− sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418− diagsNot <- skipManyTill anyMessage diagnostic
419− let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420− -- Check that if we put a lower-case drive in for A.A
421− -- the diagnostics for A.B will also be lower-case.
422− liftIO $ fileUri @?= uriB
423− let msg = _message (head (toList diags) :: Diagnostic)
424− liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425− assertFailure ("Expected redundant import but got " <> T.unpack msg)
427− , testSessionWait "haddock parse error" $ do
428− let fooContent = T.unlines
429− [ "module Foo where"
433− _ <- createDoc "Foo.hs" "haskell" fooContent
436− , [(DsError, (2, 8), "Parse error on input")
440− , testSessionWait "strip file path" $ do
444− [ "module " <> name <> " where"
445− , "value :: Maybe ()"
448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449− notification <- skipManyTill anyMessage diagnostic
456− Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457− failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458− Lens.mapMOf_ offenders failure notification
461−codeActionTests :: TestTree
462−codeActionTests = testGroup "code actions"
464− , typeWildCardActionTests
467− , suggestImportTests
469− , fixConstructorImportTests
470− , importRenameActionTests
471− , fillTypedHoleTests
473− , insertNewDefinitionTests
476−codeLensesTests :: TestTree
477−codeLensesTests = testGroup "code lenses"
481−watchedFilesTests :: TestTree
482−watchedFilesTests = testGroup "watched files"
483− [ testSession' "workspace files" $ \sessionDir -> do
484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
488− -- Expect 4 subscriptions (A does not get any because it's VFS):
489− -- - /path-to-workspace/WatchedFilesMissingModule.hs
490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493− liftIO $ length watchedFileRegs @?= 4
495− , testSession' "non workspace file" $ \sessionDir -> do
496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501− -- - /path-to-workspace/WatchedFilesMissingModule.hs
502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503− liftIO $ length watchedFileRegs @?= 2
505− -- TODO add a test for didChangeWorkspaceFolder
508−renameActionTests :: TestTree
509−renameActionTests = testGroup "rename actions"
510− [ testSession "change to local variable name" $ do
511− let content = T.unlines
512− [ "module Testing where"
513− , "foo :: Int -> Int"
514− , "foo argName = argNme"
516− doc <- createDoc "Testing.hs" "haskell" content
517− _ <- waitForDiagnostics
518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
519− executeCodeAction action
520− contentAfterAction <- documentContents doc
521− let expectedContentAfterAction = T.unlines
522− [ "module Testing where"
523− , "foo :: Int -> Int"
524− , "foo argName = argName"
526− liftIO $ expectedContentAfterAction @=? contentAfterAction
527− , testSession "change to name of imported function" $ do
528− let content = T.unlines
529− [ "module Testing where"
530− , "import Data.Maybe (maybeToList)"
531− , "foo :: Maybe a -> [a]"
532− , "foo = maybToList"
534− doc <- createDoc "Testing.hs" "haskell" content
535− _ <- waitForDiagnostics
536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
537− executeCodeAction action
538− contentAfterAction <- documentContents doc
539− let expectedContentAfterAction = T.unlines
540− [ "module Testing where"
541− , "import Data.Maybe (maybeToList)"
542− , "foo :: Maybe a -> [a]"
543− , "foo = maybeToList"
545− liftIO $ expectedContentAfterAction @=? contentAfterAction
546− , testSession "suggest multiple local variable names" $ do
547− let content = T.unlines
548− [ "module Testing where"
549− , "foo :: Char -> Char -> Char -> Char"
550− , "foo argument1 argument2 argument3 = argumentX"
552− doc <- createDoc "Testing.hs" "haskell" content
553− _ <- waitForDiagnostics
554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
557− , testSession "change infix function" $ do
558− let content = T.unlines
559− [ "module Testing where"
560− , "monus :: Int -> Int"
561− , "monus x y = max 0 (x - y)"
562− , "foo x y = x `monnus` y"
564− doc <- createDoc "Testing.hs" "haskell" content
565− _ <- waitForDiagnostics
566− actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567− [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
568− executeCodeAction fixTypo
569− contentAfterAction <- documentContents doc
570− let expectedContentAfterAction = T.unlines
571− [ "module Testing where"
572− , "monus :: Int -> Int"
573− , "monus x y = max 0 (x - y)"
574− , "foo x y = x `monus` y"
576− liftIO $ expectedContentAfterAction @=? contentAfterAction
579−typeWildCardActionTests :: TestTree
580−typeWildCardActionTests = testGroup "type wildcard actions"
581− [ testSession "global signature" $ do
582− let content = T.unlines
583− [ "module Testing where"
587− doc <- createDoc "Testing.hs" "haskell" content
588− _ <- waitForDiagnostics
589− actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
591− , "Use type signature" `T.isInfixOf` actionTitle
593− executeCodeAction addSignature
594− contentAfterAction <- documentContents doc
595− let expectedContentAfterAction = T.unlines
596− [ "module Testing where"
597− , "func :: (p -> p)"
600− liftIO $ expectedContentAfterAction @=? contentAfterAction
601− , testSession "multi-line message" $ do
602− let content = T.unlines
603− [ "module Testing where"
605− , "func x y = x + y"
607− doc <- createDoc "Testing.hs" "haskell" content
608− _ <- waitForDiagnostics
609− actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
611− , "Use type signature" `T.isInfixOf` actionTitle
613− executeCodeAction addSignature
614− contentAfterAction <- documentContents doc
615− let expectedContentAfterAction = T.unlines
616− [ "module Testing where"
617− , "func :: (Integer -> Integer -> Integer)"
618− , "func x y = x + y"
620− liftIO $ expectedContentAfterAction @=? contentAfterAction
621− , testSession "local signature" $ do
622− let content = T.unlines
623− [ "module Testing where"
624− , "func :: Int -> Int"
630− doc <- createDoc "Testing.hs" "haskell" content
631− _ <- waitForDiagnostics
632− actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633− let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
634− , "Use type signature" `T.isInfixOf` actionTitle
636− executeCodeAction addSignature
637− contentAfterAction <- documentContents doc
638− let expectedContentAfterAction = T.unlines
639− [ "module Testing where"
640− , "func :: Int -> Int"
646− liftIO $ expectedContentAfterAction @=? contentAfterAction
649−removeImportTests :: TestTree
650−removeImportTests = testGroup "remove import actions"
651− [ testSession "redundant" $ do
652− let contentA = T.unlines
653− [ "module ModuleA where"
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
656− let contentB = T.unlines
657− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658− , "module ModuleB where"
660− , "stuffB :: Integer"
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
664− _ <- waitForDiagnostics
665− [CACodeAction action@CodeAction { _title = actionTitle }]
666− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
667− liftIO $ "Remove import" @=? actionTitle
668− executeCodeAction action
669− contentAfterAction <- documentContents docB
670− let expectedContentAfterAction = T.unlines
671− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
672− , "module ModuleB where"
673− , "stuffB :: Integer"
676− liftIO $ expectedContentAfterAction @=? contentAfterAction
677− , testSession "qualified redundant" $ do
678− let contentA = T.unlines
679− [ "module ModuleA where"
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
682− let contentB = T.unlines
683− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684− , "module ModuleB where"
685− , "import qualified ModuleA"
686− , "stuffB :: Integer"
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
690− _ <- waitForDiagnostics
691− [CACodeAction action@CodeAction { _title = actionTitle }]
692− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
693− liftIO $ "Remove import" @=? actionTitle
694− executeCodeAction action
695− contentAfterAction <- documentContents docB
696− let expectedContentAfterAction = T.unlines
697− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
698− , "module ModuleB where"
699− , "stuffB :: Integer"
702− liftIO $ expectedContentAfterAction @=? contentAfterAction
703− , testSession "redundant binding" $ do
704− let contentA = T.unlines
705− [ "module ModuleA where"
707− , "stuffB :: Integer"
711− _docA <- createDoc "ModuleA.hs" "haskell" contentA
712− let contentB = T.unlines
713− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714− , "module ModuleB where"
715− , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716− , "main = print stuffB"
718− docB <- createDoc "ModuleB.hs" "haskell" contentB
719− _ <- waitForDiagnostics
720− [CACodeAction action@CodeAction { _title = actionTitle }]
721− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
722− liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
723− executeCodeAction action
724− contentAfterAction <- documentContents docB
725− let expectedContentAfterAction = T.unlines
726− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
727− , "module ModuleB where"
728− , "import ModuleA (stuffB)"
729− , "main = print stuffB"
731− liftIO $ expectedContentAfterAction @=? contentAfterAction
732− , testSession "redundant operator" $ do
733− let contentA = T.unlines
734− [ "module ModuleA where"
737− , "stuffB :: Integer"
740− _docA <- createDoc "ModuleA.hs" "haskell" contentA
741− let contentB = T.unlines
742− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743− , "module ModuleB where"
744− , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745− , "main = print A.stuffB"
747− docB <- createDoc "ModuleB.hs" "haskell" contentB
748− _ <- waitForDiagnostics
749− [CACodeAction action@CodeAction { _title = actionTitle }]
750− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
751− liftIO $ "Remove !!, <?> from import" @=? actionTitle
752− executeCodeAction action
753− contentAfterAction <- documentContents docB
754− let expectedContentAfterAction = T.unlines
755− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756− , "module ModuleB where"
757− , "import qualified ModuleA as A (stuffB)"
758− , "main = print A.stuffB"
760− liftIO $ expectedContentAfterAction @=? contentAfterAction
761− , testSession "redundant all import" $ do
762− let contentA = T.unlines
763− [ "module ModuleA where"
765− , "stuffB :: Integer"
768− _docA <- createDoc "ModuleA.hs" "haskell" contentA
769− let contentB = T.unlines
770− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771− , "module ModuleB where"
772− , "import ModuleA (A(..), stuffB)"
773− , "main = print stuffB"
775− docB <- createDoc "ModuleB.hs" "haskell" contentB
776− _ <- waitForDiagnostics
777− [CACodeAction action@CodeAction { _title = actionTitle }]
778− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
779− liftIO $ "Remove A from import" @=? actionTitle
780− executeCodeAction action
781− contentAfterAction <- documentContents docB
782− let expectedContentAfterAction = T.unlines
783− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
784− , "module ModuleB where"
785− , "import ModuleA (stuffB)"
786− , "main = print stuffB"
788− liftIO $ expectedContentAfterAction @=? contentAfterAction
789− , testSession "redundant constructor import" $ do
790− let contentA = T.unlines
791− [ "module ModuleA where"
795− _docA <- createDoc "ModuleA.hs" "haskell" contentA
796− let contentB = T.unlines
797− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798− , "module ModuleB where"
799− , "import ModuleA (D(A,B), E(F))"
802− docB <- createDoc "ModuleB.hs" "haskell" contentB
803− _ <- waitForDiagnostics
804− [CACodeAction action@CodeAction { _title = actionTitle }]
805− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
806− liftIO $ "Remove A, E, F from import" @=? actionTitle
807− executeCodeAction action
808− contentAfterAction <- documentContents docB
809− let expectedContentAfterAction = T.unlines
810− [ "{-# OPTIONS_GHC -Wunused-imports #-}"
811− , "module ModuleB where"
812− , "import ModuleA (D(B))"
815− liftIO $ expectedContentAfterAction @=? contentAfterAction
818−extendImportTests :: TestTree
819−extendImportTests = testGroup "extend import actions"
820− [ testSession "extend single line import with value" $ template
822− [ "module ModuleA where"
823− , "stuffA :: Double"
824− , "stuffA = 0.00750"
825− , "stuffB :: Integer"
829− [ "module ModuleB where"
830− , "import ModuleA as A (stuffB)"
831− , "main = print (stuffA, stuffB)"
833− (Range (Position 3 17) (Position 3 18))
834− "Add stuffA to the import list of ModuleA"
836− [ "module ModuleB where"
837− , "import ModuleA as A (stuffA, stuffB)"
838− , "main = print (stuffA, stuffB)"
840− , testSession "extend single line import with operator" $ template
842− [ "module ModuleA where"
843− , "(.*) :: Integer -> Integer -> Integer"
845− , "stuffB :: Integer"
849− [ "module ModuleB where"
850− , "import ModuleA as A (stuffB)"
851− , "main = print (stuffB .* stuffB)"
853− (Range (Position 3 17) (Position 3 18))
854− "Add .* to the import list of ModuleA"
856− [ "module ModuleB where"
857− , "import ModuleA as A ((.*), stuffB)"
858− , "main = print (stuffB .* stuffB)"
860− , testSession "extend single line import with type" $ template
862− [ "module ModuleA where"
866− [ "module ModuleB where"
867− , "import ModuleA ()"
871− (Range (Position 2 5) (Position 2 5))
872− "Add A to the import list of ModuleA"
874− [ "module ModuleB where"
875− , "import ModuleA (A)"
879− , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template
881− [ "module ModuleA where"
882− , "data A = Constructor"
885− [ "module ModuleB where"
886− , "import ModuleA (A)"
890− (Range (Position 2 5) (Position 2 5))
891− "Add Constructor to the import list of ModuleA"
893− [ "module ModuleB where"
894− , "import ModuleA (A(Constructor))"
898− , testSession "extend single line qualified import with value" $ template
900− [ "module ModuleA where"
901− , "stuffA :: Double"
902− , "stuffA = 0.00750"
903− , "stuffB :: Integer"
907− [ "module ModuleB where"
908− , "import qualified ModuleA as A (stuffB)"
909− , "main = print (A.stuffA, A.stuffB)"
911− (Range (Position 3 17) (Position 3 18))
912− "Add stuffA to the import list of ModuleA"
914− [ "module ModuleB where"
915− , "import qualified ModuleA as A (stuffA, stuffB)"
916− , "main = print (A.stuffA, A.stuffB)"
918− , testSession "extend multi line import with value" $ template
920− [ "module ModuleA where"
921− , "stuffA :: Double"
922− , "stuffA = 0.00750"
923− , "stuffB :: Integer"
927− [ "module ModuleB where"
928− , "import ModuleA (stuffB"
930− , "main = print (stuffA, stuffB)"
932− (Range (Position 3 17) (Position 3 18))
933− "Add stuffA to the import list of ModuleA"
935− [ "module ModuleB where"
936− , "import ModuleA (stuffA, stuffB"
938− , "main = print (stuffA, stuffB)"
942− template contentA contentB range expectedAction expectedContentB = do
943− _docA <- createDoc "ModuleA.hs" "haskell" contentA
944− docB <- createDoc "ModuleB.hs" "haskell" contentB
945− _ <- waitForDiagnostics
946− CACodeAction action@CodeAction { _title = actionTitle } : _
947− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
948− getCodeActions docB range
949− liftIO $ expectedAction @=? actionTitle
950− executeCodeAction action
951− contentAfterAction <- documentContents docB
952− liftIO $ expectedContentB @=? contentAfterAction
954−suggestImportTests :: TestTree
955−suggestImportTests = testGroup "suggest import actions"
956− [ testGroup "Dont want suggestion"
958− test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
960− , test False [] "f = First" [] "import Data.Monoid (First)"
962− , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963− -- package not in scope
964− , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
966− , testGroup "want suggestion"
967− [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
968− , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969− , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970− , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
971− , test True [] "f = First" [] "import Data.Monoid (First(First))"
972− , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973− , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974− , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975− , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
976− , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977− , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978− , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979− , test True [] "f = (&)" [] "import Data.Function ((&))"
980− , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
981− , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982− , test True [] "f = pack" [] "import Data.Text (pack)"
983− , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984− , test True [] "f = [] & id" [] "import Data.Function ((&))"
985− , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
989− test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990− let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991− after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992− cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993− liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994− doc <- createDoc "Test.hs" "haskell" before
995− _diags <- waitForDiagnostics
996− let defLine = length imps + 1
997− range = Range (Position defLine 0) (Position defLine maxBound)
998− actions <- getCodeActions doc range
1001− action <- liftIO $ pickActionWithTitle newImp actions
1002− executeCodeAction action
1003− contentAfterAction <- documentContents doc
1004− liftIO $ after @=? contentAfterAction
1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1009−addExtensionTests :: TestTree
1010−addExtensionTests = testGroup "add language extension actions"
1011− [ testSession "add NamedFieldPuns language extension" $ template
1013− [ "module Module where"
1015− , "data A = A { getA :: Bool }"
1018− , "f A { getA } = getA"
1020− (Range (Position 0 0) (Position 0 0))
1021− "Add NamedFieldPuns extension"
1023− [ "{-# LANGUAGE NamedFieldPuns #-}"
1024− , "module Module where"
1026− , "data A = A { getA :: Bool }"
1029− , "f A { getA } = getA"
1031− , testSession "add RecordWildCards language extension" $ template
1033− [ "module Module where"
1035− , "data A = A { getA :: Bool }"
1038− , "f A { .. } = getA"
1040− (Range (Position 0 0) (Position 0 0))
1041− "Add RecordWildCards extension"
1043− [ "{-# LANGUAGE RecordWildCards #-}"
1044− , "module Module where"
1046− , "data A = A { getA :: Bool }"
1049− , "f A { .. } = getA"
1053− template initialContent range expectedAction expectedContents = do
1054− doc <- createDoc "Module.hs" "haskell" initialContent
1055− _ <- waitForDiagnostics
1056− CACodeAction action@CodeAction { _title = actionTitle } : _
1057− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058− getCodeActions doc range
1059− liftIO $ expectedAction @=? actionTitle
1060− executeCodeAction action
1061− contentAfterAction <- documentContents doc
1062− liftIO $ expectedContents @=? contentAfterAction
1065−insertNewDefinitionTests :: TestTree
1066−insertNewDefinitionTests = testGroup "insert new definition actions"
1067− [ testSession "insert new function definition" $ do
1069− ["foo True = select [True]"
1071− ,"foo False = False"
1075− ,"someOtherCode = ()"
1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1078− _ <- waitForDiagnostics
1079− CACodeAction action@CodeAction { _title = actionTitle } : _
1080− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1081− getCodeActions docB (R 1 0 1 50)
1082− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1083− executeCodeAction action
1084− contentAfterAction <- documentContents docB
1085− liftIO $ contentAfterAction @?= T.unlines (txtB ++
1087− , "select :: [Bool] -> Bool"
1088− , "select = error \"not implemented\""
1091− , testSession "define a hole" $ do
1093− ["foo True = _select [True]"
1095− ,"foo False = False"
1099− ,"someOtherCode = ()"
1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1102− _ <- waitForDiagnostics
1103− CACodeAction action@CodeAction { _title = actionTitle } : _
1104− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1105− getCodeActions docB (R 1 0 1 50)
1106− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1107− executeCodeAction action
1108− contentAfterAction <- documentContents docB
1109− liftIO $ contentAfterAction @?= T.unlines (
1110− ["foo True = select [True]"
1112− ,"foo False = False"
1114− , "select :: [Bool] -> Bool"
1115− , "select = error \"not implemented\""
1120−fixConstructorImportTests :: TestTree
1121−fixConstructorImportTests = testGroup "fix import actions"
1122− [ testSession "fix constructor import" $ template
1124− [ "module ModuleA where"
1125− , "data A = Constructor"
1128− [ "module ModuleB where"
1129− , "import ModuleA(Constructor)"
1131− (Range (Position 1 10) (Position 1 11))
1132− "Fix import of A(Constructor)"
1134− [ "module ModuleB where"
1135− , "import ModuleA(A(Constructor))"
1139− template contentA contentB range expectedAction expectedContentB = do
1140− _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141− docB <- createDoc "ModuleB.hs" "haskell" contentB
1142− _diags <- waitForDiagnostics
1143− CACodeAction action@CodeAction { _title = actionTitle } : _
1144− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1145− getCodeActions docB range
1146− liftIO $ expectedAction @=? actionTitle
1147− executeCodeAction action
1148− contentAfterAction <- documentContents docB
1149− liftIO $ expectedContentB @=? contentAfterAction
1151−importRenameActionTests :: TestTree
1152−importRenameActionTests = testGroup "import rename actions"
1153− [ testSession "Data.Mape -> Data.Map" $ check "Map"
1154− , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where
1156− let content = T.unlines
1157− [ "module Testing where"
1158− , "import Data.Mape"
1160− doc <- createDoc "Testing.hs" "haskell" content
1161− _ <- waitForDiagnostics
1162− actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1163− let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1164− executeCodeAction changeToMap
1165− contentAfterAction <- documentContents doc
1166− let expectedContentAfterAction = T.unlines
1167− [ "module Testing where"
1168− , "import Data." <> modname
1170− liftIO $ expectedContentAfterAction @=? contentAfterAction
1172−fillTypedHoleTests :: TestTree
1173−fillTypedHoleTests = let
1175− sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
1176− sourceCode a b c = T.unlines
1177− [ "module Testing where"
1179− , "globalConvert :: Int -> String"
1180− , "globalConvert = undefined"
1182− , "globalInt :: Int"
1185− , "bar :: Int -> Int -> String"
1186− , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"
1187− , " localConvert = (flip replicate) 'x'"
1191− check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
1194− newA newB newC = testSession (T.unpack actionTitle) $ do
1195− let originalCode = sourceCode oldA oldB oldC
1196− let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
1198− _ <- waitForDiagnostics
1199− actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1201− executeCodeAction chosenAction
1202− modifiedCode <- documentContents doc
1203− liftIO $ expectedCode @=? modifiedCode
1205− testGroup "fill typed holes"
1206− [ check "replace hole `_` with show"
1210− , check "replace hole `_` with globalConvert"
1212− "globalConvert" "n" "n"
1214−#if MIN_GHC_API_VERSION(8,6,0)
1215− , check "replace hole `_convertme` with localConvert"
1216− "_convertme" "n" "n"
1217− "localConvert" "n" "n"
1220− , check "replace hole `_b` with globalInt"
1222− "_a" "globalInt" "_c"
1224− , check "replace hole `_c` with globalInt"
1226− "_a" "_b" "globalInt"
1228−#if MIN_GHC_API_VERSION(8,6,0)
1229− , check "replace hole `_c` with parameterInt"
1231− "_a" "_b" "parameterInt"
1235−addSigActionTests :: TestTree
1236−addSigActionTests = let
1237− header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
1238− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1239− before def = T.unlines [header, moduleH, def]
1240− after' def sig = T.unlines [header, moduleH, sig, def]
1242− def >:: sig = testSession (T.unpack def) $ do
1243− let originalCode = before def
1244− let expectedCode = after' def sig
1245− doc <- createDoc "Sigs.hs" "haskell" originalCode
1246− _ <- waitForDiagnostics
1247− actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1248− chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1249− executeCodeAction chosenAction
1250− modifiedCode <- documentContents doc
1251− liftIO $ expectedCode @=? modifiedCode
1253− testGroup "add signature"
1254− [ "abc = True" >:: "abc :: Bool"
1255− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1256− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1257− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1258− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1259− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260− , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1263−addSigLensesTests :: TestTree
1264−addSigLensesTests = let
1265− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1266− notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1267− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1268− other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1269− before withMissing def
1270− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1271− after' withMissing def sig
1272− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
1274− sigSession withMissing def sig = testSession (T.unpack def) $ do
1275− let originalCode = before withMissing def
1276− let expectedCode = after' withMissing def sig
1277− doc <- createDoc "Sigs.hs" "haskell" originalCode
1278− [CodeLens {_command = Just c}] <- getCodeLenses doc
1280− modifiedCode <- getDocumentEdit doc
1281− liftIO $ expectedCode @=? modifiedCode
1283− testGroup "add signature"
1285− [ sigSession enableWarnings "abc = True" "abc :: Bool"
1286− , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1287− , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1288− , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1289− , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1290− , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1291− , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1293− | (title, enableWarnings) <-
1294− [("with warnings enabled", True)
1295− ,("with warnings disabled", False)
1299−checkDefs :: [Location] -> Session [Expect] -> Session ()
1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1302− check (ExpectRange expectedRange) = do
1303− assertNDefinitionsFound 1 defs
1304− assertRangeCorrect (head defs) expectedRange
1305− check (ExpectLocation expectedLocation) = do
1306− assertNDefinitionsFound 1 defs
1307− liftIO $ head defs @?= expectedLocation
1308− check ExpectNoDefinitions = do
1309− assertNDefinitionsFound 0 defs
1310− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311− check _ = pure () -- all other expectations not relevant to getDefinition
1313− assertNDefinitionsFound :: Int -> [a] -> Session ()
1314− assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1316− assertRangeCorrect Location{_range = foundRange} expectedRange =
1317− liftIO $ expectedRange @=? foundRange
1320−findDefinitionAndHoverTests :: TestTree
1321−findDefinitionAndHoverTests = let
1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324− doc <- openTestDataDoc (dir </> sourceFilePath)
1325− found <- get doc pos
1326− check found targetRange
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
1336− Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1337− ,_range = rangeInHover } ->
1339− ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340− ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1341− ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342− ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
1343− _ -> pure () -- all other expectations not relevant to hover
1344− _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1346− extractLineColFromHoverMsg :: T.Text -> [T.Text]
1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
1349− checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1350− checkHoverRange expectedRange rangeInHover msg =
1352− lineCol = extractLineColFromHoverMsg msg
1353− -- looks like hovers use 1-based numbering while definitions use 0-based
1354− -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
1355− adjust Position{_line = l, _character = c} =
1356− Position{_line = l + 1, _character = c + 1}
1358− case map (read . T.unpack) lineCol of
1359− [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c
1360− _ -> liftIO $ assertFailure $
1361− "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
1362− "\n but got: " <> show (msg, rangeInHover)
1364− assertFoundIn :: T.Text -> T.Text -> Assertion
1365− assertFoundIn part whole = assertBool
1366− (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
1367− (part `T.isInfixOf` whole)
1369− sourceFilePath = T.unpack sourceFileName
1370− sourceFileName = "GotoHover.hs"
1372− mkFindTests tests = testGroup "get"
1373− [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
1375− , checkFileCompiles sourceFilePath ]
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
1379− testM runDef runHover look expect title =
1380− ( runDef $ tst def look expect title
1381− , runHover $ tst hover look expect title ) where
1382− def = (getDefinitions, checkDefs)
1383− hover = (getHover , checkHover)
1384− --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1386− -- search locations expectations on results
1387− fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1388− fffL8 = Position 12 4 ;
1389− fffL14 = Position 18 7 ;
1390− aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1391− dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1392− dcL12 = Position 16 11 ;
1393− xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1394− tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1395− vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1396− opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1397− opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1398− aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1399− b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1400− xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1401− clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1402− clL25 = Position 29 9
1403− eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1404− dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1405− dnbL30 = Position 34 23
1406− lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1407− lclL33 = Position 37 22
1408− mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409− mclL37 = Position 41 1
1410− spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411− docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1412− ; constr = [ExpectHoverText ["Monad m"]]
1413− eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414− intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415− tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416− intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417− chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418− txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419− lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420− outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421− innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422− imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423− reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
1426− -- def hover look expect
1427− [ test yes yes fffL4 fff "field in record definition"
1428− , test broken broken fffL8 fff "field in record construction #71"
1429− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430− , test yes yes aaaL14 aaa "top-level name" -- 120
1431− , test yes yes dcL7 tcDC "data constructor record #247"
1432− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1433− , test yes yes tcL6 tcData "type constructor #248" -- 147
1434− , test broken yes xtcL5 xtc "type constructor external #248,249"
1435− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1436− , test yes yes vvL16 vv "plain parameter" -- 120
1437− , test yes yes aL18 apmp "pattern match name" -- 120
1438− , test yes yes opL16 op "top-level operator" -- 120, 123
1439− , test yes yes opL18 opp "parameter operator" -- 120
1440− , test yes yes b'L19 bp "name in backticks" -- 120
1441− , test yes yes clL23 cls "class in instance declaration #250"
1442− , test yes yes clL25 cls "class in signature #250" -- 147
1443− , test broken yes eclL15 ecls "external class in signature #249,250"
1444− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445− , test yes yes dnbL30 dnb "do-notation lookup"
1446− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447− , test yes yes lclL33 lcb "listcomp lookup"
1448− , test yes yes mclL36 mcl "top-level fn 1st clause"
1449− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450− , test yes yes spaceL37 space "top-level fn on space #315"
1451− , test no broken docL41 doc "documentation #7"
1452− , test no yes eitL40 kindE "kind of Either #273"
1453− , test no yes intL40 kindI "kind of Int #273"
1454− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455− , test no yes intL41 litI "literal Int in hover info #274"
1456− , test no yes chrL36 litC "literal Char in hover info #274"
1457− , test no yes txtL8 litT "literal Text in hover info #274"
1458− , test no yes lstL43 litL "literal List in hover info #274"
1459− , test no yes docL41 constr "type constraint in hover info #283"
1460− , test broken broken outL45 outSig "top-level signature #310"
1461− , test broken broken innL48 innSig "inner signature #310"
1462− , testM yes yes imported importedSig "Imported symbol"
1463− , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
1465− where yes, broken :: (TestTree -> Maybe TestTree)
1466− yes = Just -- test should run and pass
1467− broken = Just . (`xfail` "known broken")
1468− no = const Nothing -- don't run this test at all
1470−checkFileCompiles :: FilePath -> TestTree
1471−checkFileCompiles fp =
1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473− void (openTestDataDoc (dir </> fp))
1474− expectNoMoreDiagnostics 0.5
1478−pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
1483− [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1484− , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"
1485− , "module Testing where"
1486− , "import Data.Proxy"
1487− , "import GHC.TypeLits"
1488− -- This function fails without plugins being initialized.
1489− , "f :: forall n. KnownNat n => Proxy n -> Integer"
1490− , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"
1491− , "foo :: Int -> Int -> Int"
1492− , "foo a b = a + c"
1494− _ <- createDoc "Testing.hs" "haskell" content
1497− [(DsError, (8, 14), "Variable not in scope: c")]
1501−cppTests :: TestTree
1504− [ testCase "cpp-error" $ do
1507− [ "{-# LANGUAGE CPP #-}",
1508− "module Testing where",
1512− -- The error locations differ depending on which C-preprocessor is used.
1513− -- Some give the column number and others don't (hence -1). Assert either
1515− (run $ expectError content (2, -1))
1517− let _ = e :: HUnitFailure
1518− run $ expectError content (2, 1)
1520− , testSessionWait "cpp-ghcide" $ do
1521− _ <- createDoc "A.hs" "haskell" $ T.unlines
1522− ["{-# LANGUAGE CPP #-}"
1524− ,"#ifdef __GHCIDE__"
1530− expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1533− expectError :: T.Text -> Cursor -> Session ()
1534− expectError content cursor = do
1535− _ <- createDoc "Testing.hs" "haskell" content
1538− [(DsError, cursor, "error: unterminated")]
1541− expectNoMoreDiagnostics 0.5
1543−preprocessorTests :: TestTree
1544−preprocessorTests = testSessionWait "preprocessor" $ do
1547− [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
1548− , "module Testing where"
1549− , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1551− _ <- createDoc "Testing.hs" "haskell" content
1554− [(DsError, (2, 8), "Variable not in scope: z")]
1559−safeTests :: TestTree
1563− [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564− testSessionWait "load" $ do
1567− ["{-# LANGUAGE Trustworthy #-}"
1569− ,"import System.IO.Unsafe"
1570− ,"import System.IO"
1571− ,"trustWorthyId :: a -> a"
1572− ,"trustWorthyId i = unsafePerformIO $ do"
1573− ," putStrLn \"I'm safe\""
1577− ["{-# LANGUAGE Safe #-}"
1580− ,"safeId :: a -> a"
1581− ,"safeId = trustWorthyId"
1584− _ <- createDoc "A.hs" "haskell" sourceA
1585− _ <- createDoc "B.hs" "haskell" sourceB
1586− expectNoMoreDiagnostics 1 ]
1592− [ -- Test for https://github.com/digital-asset/ghcide/pull/212
1593− testSessionWait "load" $ do
1596− [ "{-# LANGUAGE PackageImports #-}",
1597− "{-# LANGUAGE TemplateHaskell #-}",
1599− "import \"template-haskell\" Language.Haskell.TH",
1601− "a = $(litE $ IntegerL 3)"
1605− [ "{-# LANGUAGE PackageImports #-}",
1606− "{-# LANGUAGE TemplateHaskell #-}",
1609− "import \"template-haskell\" Language.Haskell.TH",
1611− "b = $(litE $ IntegerL $ a) + n"
1613− _ <- createDoc "A.hs" "haskell" sourceA
1614− _ <- createDoc "B.hs" "haskell" sourceB
1615− expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616− , testSessionWait "newtype-closure" $ do
1619− [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620− ,"{-# LANGUAGE TemplateHaskell #-}"
1621− ,"module A (a) where"
1622− ,"import Data.Data"
1623− ,"import Language.Haskell.TH"
1624− ,"newtype A = A () deriving (Data)"
1629− [ "{-# LANGUAGE TemplateHaskell #-}"
1634− _ <- createDoc "A.hs" "haskell" sourceA
1635− _ <- createDoc "B.hs" "haskell" sourceB
1639−completionTests :: TestTree
1641− = testGroup "completion"
1642− [ testSessionWait "variable" $ do
1643− let source = T.unlines ["module A where", "f = hea"]
1644− docId <- createDoc "A.hs" "haskell" source
1645− compls <- getCompletions docId (Position 1 7)
1646− liftIO $ map dropDocs compls @?=
1647− [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1648− let [CompletionItem { _documentation = headDocs}] = compls
1649− checkDocText "head" headDocs [ "Defined in 'Prelude'"
1650−#if MIN_GHC_API_VERSION(8,6,5)
1651− , "Extract the first element of a list"
1654− , testSessionWait "constructor" $ do
1655− let source = T.unlines ["module A where", "f = Tru"]
1656− docId <- createDoc "A.hs" "haskell" source
1657− compls <- getCompletions docId (Position 1 7)
1658− liftIO $ map dropDocs compls @?=
1659− [ complItem "True" (Just CiConstructor) (Just "Bool")
1660−#if MIN_GHC_API_VERSION(8,6,0)
1661− , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1663− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1666− , testSessionWait "type" $ do
1667− let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668− docId <- createDoc "A.hs" "haskell" source
1669− expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1670− changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1671− compls <- getCompletions docId (Position 2 7)
1672− liftIO $ map dropDocs compls @?=
1673− [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")
1674− , complItem "Bool" (Just CiStruct) (Just "*") ]
1675− let [ CompletionItem { _documentation = boundedDocs},
1676− CompletionItem { _documentation = boolDocs } ] = compls
1677− checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1678−#if MIN_GHC_API_VERSION(8,6,5)
1679− , "name the upper and lower limits"
1682− checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1683− , testSessionWait "qualified" $ do
1684− let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685− docId <- createDoc "A.hs" "haskell" source
1686− expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1687− changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1688− compls <- getCompletions docId (Position 2 15)
1689− liftIO $ map dropDocs compls @?=
1690− [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1691− let [CompletionItem { _documentation = headDocs}] = compls
1692− checkDocText "head" headDocs [ "Defined in 'Prelude'"
1693−#if MIN_GHC_API_VERSION(8,6,5)
1694− , "Extract the first element of a list"
1697− , testSessionWait "keyword" $ do
1698− let source = T.unlines ["module A where", "f = newty"]
1699− docId <- createDoc "A.hs" "haskell" source
1700− compls <- getCompletions docId (Position 1 9)
1701− liftIO $ compls @?= [keywordItem "newtype"]
1702− , testSessionWait "type context" $ do
1703− let source = T.unlines
1704− [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705− , "module A () where"
1708− docId <- createDoc "A.hs" "haskell" source
1709− expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1711− [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712− [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713− , "module A () where"
1718− -- At this point the module parses but does not typecheck.
1719− -- This should be sufficient to detect that we are in a
1720− -- type context and only show the completion to the type.
1721− compls <- getCompletions docId (Position 3 11)
1722− liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1725− dropDocs :: CompletionItem -> CompletionItem
1726− dropDocs ci = ci { _documentation = Nothing }
1727− complItem label kind ty = CompletionItem
1731− , _detail = (":: " <>) <$> ty
1732− , _documentation = Nothing
1733− , _deprecated = Nothing
1734− , _preselect = Nothing
1735− , _sortText = Nothing
1736− , _filterText = Nothing
1737− , _insertText = Nothing
1738− , _insertTextFormat = Just PlainText
1739− , _textEdit = Nothing
1740− , _additionalTextEdits = Nothing
1741− , _commitCharacters = Nothing
1742− , _command = Nothing
1745− keywordItem label = CompletionItem
1747− , _kind = Just CiKeyword
1749− , _detail = Nothing
1750− , _documentation = Nothing
1751− , _deprecated = Nothing
1752− , _preselect = Nothing
1753− , _sortText = Nothing
1754− , _filterText = Nothing
1755− , _insertText = Nothing
1756− , _insertTextFormat = Nothing
1757− , _textEdit = Nothing
1758− , _additionalTextEdits = Nothing
1759− , _commitCharacters = Nothing
1760− , _command = Nothing
1763− getDocText (CompletionDocString s) = s
1764− getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1765− checkDocText thing Nothing _
1766− = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"
1767− checkDocText thing (Just doc) items
1768− = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $
1769− all (`T.isInfixOf` getDocText doc) items
1771−outlineTests :: TestTree
1772−outlineTests = testGroup
1774− [ testSessionWait "type class" $ do
1775− let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776− docId <- createDoc "A.hs" "haskell" source
1777− symbols <- getDocumentSymbols docId
1778− liftIO $ symbols @?= Left
1782− [ classSymbol "A a"
1784− [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
1787− , testSessionWait "type class instance " $ do
1788− let source = T.unlines ["class A a where", "instance A () where"]
1789− docId <- createDoc "A.hs" "haskell" source
1790− symbols <- getDocumentSymbols docId
1791− liftIO $ symbols @?= Left
1792− [ classSymbol "A a" (R 0 0 0 15) []
1793− , docSymbol "A ()" SkInterface (R 1 0 1 19)
1795− , testSessionWait "type family" $ do
1796− let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797− docId <- createDoc "A.hs" "haskell" source
1798− symbols <- getDocumentSymbols docId
1799− liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1800− , testSessionWait "type family instance " $ do
1801− let source = T.unlines
1802− [ "{-# language TypeFamilies #-}"
1803− , "type family A a"
1804− , "type instance A () = ()"
1806− docId <- createDoc "A.hs" "haskell" source
1807− symbols <- getDocumentSymbols docId
1808− liftIO $ symbols @?= Left
1809− [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1810− , docSymbol "A ()" SkInterface (R 2 0 2 23)
1812− , testSessionWait "data family" $ do
1813− let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814− docId <- createDoc "A.hs" "haskell" source
1815− symbols <- getDocumentSymbols docId
1816− liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1817− , testSessionWait "data family instance " $ do
1818− let source = T.unlines
1819− [ "{-# language TypeFamilies #-}"
1820− , "data family A a"
1821− , "data instance A () = A ()"
1823− docId <- createDoc "A.hs" "haskell" source
1824− symbols <- getDocumentSymbols docId
1825− liftIO $ symbols @?= Left
1826− [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1827− , docSymbol "A ()" SkInterface (R 2 0 2 25)
1829− , testSessionWait "constant" $ do
1830− let source = T.unlines ["a = ()"]
1831− docId <- createDoc "A.hs" "haskell" source
1832− symbols <- getDocumentSymbols docId
1833− liftIO $ symbols @?= Left
1834− [docSymbol "a" SkFunction (R 0 0 0 6)]
1835− , testSessionWait "pattern" $ do
1836− let source = T.unlines ["Just foo = Just 21"]
1837− docId <- createDoc "A.hs" "haskell" source
1838− symbols <- getDocumentSymbols docId
1839− liftIO $ symbols @?= Left
1840− [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1841− , testSessionWait "pattern with type signature" $ do
1842− let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843− docId <- createDoc "A.hs" "haskell" source
1844− symbols <- getDocumentSymbols docId
1845− liftIO $ symbols @?= Left
1846− [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1847− , testSessionWait "function" $ do
1848− let source = T.unlines ["a x = ()"]
1849− docId <- createDoc "A.hs" "haskell" source
1850− symbols <- getDocumentSymbols docId
1851− liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1852− , testSessionWait "type synonym" $ do
1853− let source = T.unlines ["type A = Bool"]
1854− docId <- createDoc "A.hs" "haskell" source
1855− symbols <- getDocumentSymbols docId
1856− liftIO $ symbols @?= Left
1857− [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1858− , testSessionWait "datatype" $ do
1859− let source = T.unlines ["data A = C"]
1860− docId <- createDoc "A.hs" "haskell" source
1861− symbols <- getDocumentSymbols docId
1862− liftIO $ symbols @?= Left
1863− [ docSymbolWithChildren "A"
1866− [docSymbol "C" SkConstructor (R 0 9 0 10)]
1868− , testSessionWait "record fields" $ do
1869− let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870− docId <- createDoc "A.hs" "haskell" source
1871− symbols <- getDocumentSymbols docId
1872− liftIO $ symbols @=? Left
1873− [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874− [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875− [ docSymbol "x" SkField (R 1 2 1 3)
1876− , docSymbol "y" SkField (R 2 4 2 5)
1880− , testSessionWait "import" $ do
1881− let source = T.unlines ["import Data.Maybe"]
1882− docId <- createDoc "A.hs" "haskell" source
1883− symbols <- getDocumentSymbols docId
1884− liftIO $ symbols @?= Left
1885− [docSymbolWithChildren "imports"
1888− [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1891− , testSessionWait "multiple import" $ do
1892− let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893− docId <- createDoc "A.hs" "haskell" source
1894− symbols <- getDocumentSymbols docId
1895− liftIO $ symbols @?= Left
1896− [docSymbolWithChildren "imports"
1899− [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900− , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1903− , testSessionWait "foreign import" $ do
1904− let source = T.unlines
1905− [ "{-# language ForeignFunctionInterface #-}"
1906− , "foreign import ccall \"a\" a :: Int"
1908− docId <- createDoc "A.hs" "haskell" source
1909− symbols <- getDocumentSymbols docId
1910− liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1911− , testSessionWait "foreign export" $ do
1912− let source = T.unlines
1913− [ "{-# language ForeignFunctionInterface #-}"
1914− , "foreign export ccall odd :: Int -> Bool"
1916− docId <- createDoc "A.hs" "haskell" source
1917− symbols <- getDocumentSymbols docId
1918− liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1921− docSymbol name kind loc =
1922− DocumentSymbol name Nothing kind Nothing loc loc Nothing
1923− docSymbol' name kind loc selectionLoc =
1924− DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing
1925− docSymbolD name detail kind loc =
1926− DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1927− docSymbolWithChildren name kind loc cc =
1928− DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1929− docSymbolWithChildren' name kind loc selectionLoc cc =
1930− DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
1931− moduleSymbol name loc cc = DocumentSymbol name
1938− classSymbol name loc cc = DocumentSymbol name
1946−pattern R :: Int -> Int -> Int -> Int -> Range
1947−pattern R x y x' y' = Range (Position x y) (Position x' y')
1949−xfail :: TestTree -> String -> TestTree
1950−xfail = flip expectFailBecause
1952−xfail8101 :: TestTree -> String -> TestTree
1953−#if MIN_GHC_API_VERSION(8,10,0)
1954−xfail8101 = flip expectFailBecause
1960− = ExpectRange Range -- Both gotoDef and hover should report this range
1961− | ExpectLocation Location
1962−-- | ExpectDefRange Range -- Only gotoDef should report this range
1963− | ExpectHoverRange Range -- Only hover should report this range
1964− | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1965− | ExpectExternFail -- definition lookup in other file expected to fail
1966− | ExpectNoDefinitions
1968−-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1971−mkR :: Int -> Int -> Int -> Int -> Expect
1972−mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1977−haddockTests :: TestTree
1979− = testGroup "haddock"
1980− [ testCase "Num" $ checkHaddock
1982− [ "However, '(+)' and '(*)' are"
1983− , "customarily expected to define a ring and have the following properties:"
1985− , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986− , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987− , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1993− , "However, `(+)` and `(*)` are"
1994− , "customarily expected to define a ring and have the following properties: "
1995− , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996− , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997− , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
2000− , testCase "unsafePerformIO" $ checkHaddock
2003− , "different precautions:"
2005− , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006− , " that calls 'unsafePerformIO'. If the call is inlined,"
2007− , " the I\\/O may be performed more than once."
2009− , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010− , " elimination being performed on the module."
2018− , "different precautions: "
2019− , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020− , " that calls `unsafePerformIO` . If the call is inlined,"
2021− , " the I/O may be performed more than once."
2023− , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024− , " elimination being performed on the module."
2030− checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2032−cradleTests :: TestTree
2033−cradleTests = testGroup "cradle"
2034− [testGroup "dependencies" [sessionDepsArePickedUp]
2035− ,testGroup "loading" [loadCradleOnlyonce]
2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2039−loadCradleOnlyonce :: TestTree
2040−loadCradleOnlyonce = testGroup "load cradle only once"
2041− [ testSession' "implicit" implicit
2042− , testSession' "direct" direct
2046− liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047− "cradle: {direct: {arguments: []}}"
2049− implicit dir = test dir
2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052− msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053− liftIO $ length msgs @?= 1
2054− changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056− liftIO $ length msgs @?= 0
2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059− liftIO $ length msgs @?= 0
2062−dependentFileTest :: TestTree
2063−dependentFileTest = testGroup "addDependentFile"
2064− [testGroup "file-changed" [testSession' "test" test]
2068− -- If the file contains B then no type error
2069− -- otherwise type error
2070− liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071− let fooContent = T.unlines
2072− [ "{-# LANGUAGE TemplateHaskell #-}"
2073− , "module Foo where"
2074− , "import Language.Haskell.TH.Syntax"
2077− , " qAddDependentFile \"dep-file.txt\""
2078− , " f <- qRunIO (readFile \"dep-file.txt\")"
2079− , " if f == \"B\" then [| 1 |] else lift f)"
2081− let bazContent = T.unlines ["module Baz where", "import Foo"]
2082− _ <-createDoc "Foo.hs" "haskell" fooContent
2083− doc <- createDoc "Baz.hs" "haskell" bazContent
2085− [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086− -- Now modify the dependent file
2087− liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088− let change = TextDocumentContentChangeEvent
2089− { _range = Just (Range (Position 2 0) (Position 2 6))
2090− , _rangeLength = Nothing
2093− -- Modifying Baz will now trigger Foo to be rebuilt as well
2094− changeDoc doc [change]
2095− expectDiagnostics [("Foo.hs", [])]
2098−cradleLoadedMessage :: Session FromServerMessage
2099−cradleLoadedMessage = satisfy $ \case
2100− NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2103−cradleLoadedMethod :: T.Text
2104−cradleLoadedMethod = "ghcide/cradle/loaded"
2106−-- Stack sets this which trips up cabal in the multi-component tests.
2107−-- However, our plugin tests rely on those env vars so we unset it locally.
2108−withoutStackEnv :: IO a -> IO a
2111− (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112− (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2115− [ "GHC_PACKAGE_PATH"
2116− , "GHC_ENVIRONMENT"
2117− , "HASKELL_DIST_DIR"
2118− , "HASKELL_PACKAGE_SANDBOX"
2119− , "HASKELL_PACKAGE_SANDBOXES"
2121− restore var Nothing = unsetEnv var
2122− restore var (Just val) = setEnv var val True
2124−simpleMultiTest :: TestTree
2125−simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126− let aPath = dir </> "a/A.hs"
2127− bPath = dir </> "b/B.hs"
2128− aSource <- liftIO $ readFileUtf8 aPath
2129− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130− expectNoMoreDiagnostics 0.5
2131− bSource <- liftIO $ readFileUtf8 bPath
2132− bdoc <- createDoc bPath "haskell" bSource
2133− expectNoMoreDiagnostics 0.5
2134− locs <- getDefinitions bdoc (Position 2 7)
2135− let fooL = mkL adoc 2 0 2 3
2136− checkDefs locs (pure [fooL])
2137− expectNoMoreDiagnostics 0.5
2139−-- Like simpleMultiTest but open the files in the other order
2140−simpleMultiTest2 :: TestTree
2141−simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142− let aPath = dir </> "a/A.hs"
2143− bPath = dir </> "b/B.hs"
2144− bSource <- liftIO $ readFileUtf8 bPath
2145− bdoc <- createDoc bPath "haskell" bSource
2146− expectNoMoreDiagnostics 5
2147− aSource <- liftIO $ readFileUtf8 aPath
2148− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149− -- Need to have some delay here or the test fails
2150− expectNoMoreDiagnostics 5
2151− locs <- getDefinitions bdoc (Position 2 7)
2152− let fooL = mkL adoc 2 0 2 3
2153− checkDefs locs (pure [fooL])
2154− expectNoMoreDiagnostics 0.5
2156−sessionDepsArePickedUp :: TestTree
2157−sessionDepsArePickedUp = testSession'
2158− "session-deps-are-picked-up"
2162− (dir </> "hie.yaml")
2163− "cradle: {direct: {arguments: []}}"
2164− -- Open without OverloadedStrings and expect an error.
2165− doc <- createDoc "Foo.hs" "haskell" fooContent
2167− [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168− -- Update hie.yaml to enable OverloadedStrings.
2171− (dir </> "hie.yaml")
2172− "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173− -- Send change event.
2175− TextDocumentContentChangeEvent
2176− { _range = Just (Range (Position 4 0) (Position 4 0)),
2177− _rangeLength = Nothing,
2180− changeDoc doc [change]
2182− expectDiagnostics [("Foo.hs", [])]
2186− [ "module Foo where",
2187− "import Data.Text",
2193----------------------------------------------------------------------
53----------------------------------------------------------------------
@@ -2197,300 +57,18 @@ sessionDepsArePickedUp = testSession'
2197testSession :: String -> Session () -> TestTree
57testSession :: String -> Session () -> TestTree
2198testSession name = testCase name . run
58testSession name = testCase name . run
2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2203−testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204−testSession' name = testCase name . run'
2206−testSessionWait :: String -> Session () -> TestTree
2207−testSessionWait name = testSession name .
2208− -- Check that any diagnostics produced were already consumed by the test case.
2210− -- If in future we add test cases where we don't care about checking the diagnostics,
2211− -- this could move elsewhere.
2213− -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2214− ( >> expectNoMoreDiagnostics 0.5)
2216−pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
2217−pickActionWithTitle title actions = do
2218− assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219− return $ head matches
2223− | CACodeAction CodeAction { _title = actionTitle } <- actions
2227− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2228− , title == actionTitle
2231−mkRange :: Int -> Int -> Int -> Int -> Range
2232−mkRange a b c d = Range (Position a b) (Position c d)
2234run :: Session a -> IO a
61run :: Session a -> IO a
2235−run s = withTempDir $ \dir -> runInDir dir s
62+run s = withTempDir $ \dir -> do
2236−
63+ let hieCoreExePath = mainWorkspace </> exe "compiler/hie-core/hie-core-exe"
2237−runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
64+ hieCoreExe <- locateRunfiles hieCoreExePath
2238−runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239− copyTestDataFiles dir prefix
2240− runInDir dir (s dir)
2242−copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243−copyTestDataFiles dir prefix = do
2244− -- Copy all the test data files to the temporary workspace
2245− testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246− for_ testDataFiles $ \f -> do
2247− createDirectoryIfMissing True $ dir </> takeDirectory f
2248− copyFile ("test/data" </> prefix </> f) (dir </> f)
2250−run' :: (FilePath -> Session a) -> IO a
2251−run' s = withTempDir $ \dir -> runInDir dir (s dir)
2253−runInDir :: FilePath -> Session a -> IO a
2255− ghcideExe <- locateGhcideExecutable
2257− -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2258− -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2259− createDirectoryIfMissing True $ dir ++ "/Data"
2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
65+ let cmd = unwords [hieCoreExe, "--lsp", "--cwd", dir]
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
66 -- HIE calls getXgdDirectory which assumes that HOME is set.
2264 -- Only sets HOME if it wasn't already set.
67 -- Only sets HOME if it wasn't already set.
2265 setEnv "HOME" "/homeless-shelter" False
68 setEnv "HOME" "/homeless-shelter" False
2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
2267− runSessionWithConfig conf cmd lspTestCaps dir s
69+ runSessionWithConfig conf cmd fullCaps dir s
2269 conf = defaultConfig
71 conf = defaultConfig
2270− -- If you uncomment this you can see all logging
72+ -- If you uncomment this you can see all messages
2271 -- which can be quite useful for debugging.
73 -- which can be quite useful for debugging.
2272− -- { logStdErr = True, logColor = False }
2273− -- If you really want to, you can also see all messages
2274− -- { logMessages = True, logColor = False }
74+ -- { logMessages = True, logColor = False, logStdErr = True }
2276−openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2277−openTestDataDoc path = do
2278− source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
2281−findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282−findCodeActions doc range expectedTitles = do
2283− actions <- getCodeActions doc range
2284− let matches = sequence
2287− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288− , actionTitle == expectedTitle ]
2289− | expectedTitle <- expectedTitles]
2292− | CACodeAction CodeAction { _title = actionTitle } <- actions
2294− ++ " is not a superset of "
2295− ++ show expectedTitles
2296− liftIO $ case matches of
2297− Nothing -> assertFailure msg
2299− return (fromJust matches)
2301−findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302−findCodeAction doc range t = head <$> findCodeActions doc range [t]
2304−unitTests :: TestTree
2307− [ testCase "empty file path does NOT work with the empty String literal" $
2308− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309− , testCase "empty file path works using toNormalizedFilePath'" $
2310− uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311− , testCase "empty path URI" $ do
2312− Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313− uriScheme @?= "file:"
2315− , testCase "from empty path URI" $ do
2316− let uri = Uri "file://"
2317− uriToFilePath' uri @?= Just ""
2320−positionMappingTests :: TestTree
2321−positionMappingTests =
2322− testGroup "position mapping"
2323− [ testGroup "toCurrent"
2324− [ testCase "before" $
2326− (Range (Position 0 1) (Position 0 3))
2328− (Position 0 0) @?= Just (Position 0 0)
2329− , testCase "after, same line, same length" $
2331− (Range (Position 0 1) (Position 0 3))
2333− (Position 0 3) @?= Just (Position 0 3)
2334− , testCase "after, same line, increased length" $
2336− (Range (Position 0 1) (Position 0 3))
2338− (Position 0 3) @?= Just (Position 0 4)
2339− , testCase "after, same line, decreased length" $
2341− (Range (Position 0 1) (Position 0 3))
2343− (Position 0 3) @?= Just (Position 0 2)
2344− , testCase "after, next line, no newline" $
2346− (Range (Position 0 1) (Position 0 3))
2348− (Position 1 3) @?= Just (Position 1 3)
2349− , testCase "after, next line, newline" $
2351− (Range (Position 0 1) (Position 0 3))
2353− (Position 1 0) @?= Just (Position 2 0)
2354− , testCase "after, same line, newline" $
2356− (Range (Position 0 1) (Position 0 3))
2358− (Position 0 4) @?= Just (Position 1 2)
2359− , testCase "after, same line, newline + newline at end" $
2361− (Range (Position 0 1) (Position 0 3))
2363− (Position 0 4) @?= Just (Position 2 1)
2364− , testCase "after, same line, newline + newline at end" $
2366− (Range (Position 0 1) (Position 0 1))
2368− (Position 0 1) @?= Just (Position 0 4)
2370− , testGroup "fromCurrent"
2371− [ testCase "before" $
2373− (Range (Position 0 1) (Position 0 3))
2375− (Position 0 0) @?= Just (Position 0 0)
2376− , testCase "after, same line, same length" $
2378− (Range (Position 0 1) (Position 0 3))
2380− (Position 0 3) @?= Just (Position 0 3)
2381− , testCase "after, same line, increased length" $
2383− (Range (Position 0 1) (Position 0 3))
2385− (Position 0 4) @?= Just (Position 0 3)
2386− , testCase "after, same line, decreased length" $
2388− (Range (Position 0 1) (Position 0 3))
2390− (Position 0 2) @?= Just (Position 0 3)
2391− , testCase "after, next line, no newline" $
2393− (Range (Position 0 1) (Position 0 3))
2395− (Position 1 3) @?= Just (Position 1 3)
2396− , testCase "after, next line, newline" $
2398− (Range (Position 0 1) (Position 0 3))
2400− (Position 2 0) @?= Just (Position 1 0)
2401− , testCase "after, same line, newline" $
2403− (Range (Position 0 1) (Position 0 3))
2405− (Position 1 2) @?= Just (Position 0 4)
2406− , testCase "after, same line, newline + newline at end" $
2408− (Range (Position 0 1) (Position 0 3))
2410− (Position 2 1) @?= Just (Position 0 4)
2411− , testCase "after, same line, newline + newline at end" $
2413− (Range (Position 0 1) (Position 0 1))
2415− (Position 0 4) @?= Just (Position 0 1)
2417− , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
2418− [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
2419− -- Note that it is important to use suchThatMap on all values at once
2420− -- instead of only using it on the position. Otherwise you can get
2421− -- into situations where there is no position that can be mapped back
2422− -- for the edit which will result in QuickCheck looping forever.
2425− range <- genRange rope
2426− PrintableText replacement <- arbitrary
2427− oldPos <- genPosition rope
2428− pure (range, replacement, oldPos)
2431− (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
2432− \(range, replacement, oldPos, newPos) ->
2433− fromCurrent range replacement newPos === Just oldPos
2434− , testProperty "toCurrent r t <=< fromCurrent r t" $ do
2437− range <- genRange rope
2438− PrintableText replacement <- arbitrary
2439− let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
2440− newPos <- genPosition newRope
2441− pure (range, replacement, newPos)
2444− (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445− \(range, replacement, newPos, oldPos) ->
2446− toCurrent range replacement oldPos === Just newPos
2450−newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2453−instance Arbitrary PrintableText where
2454− arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2458−genRope = Rope.fromText . getPrintableText <$> arbitrary
2460−genPosition :: Rope -> Gen Position
2462− row <- choose (0, max 0 $ rows - 1)
2463− let columns = Rope.columns (nthLine row r)
2464− column <- choose (0, max 0 $ columns - 1)
2465− pure $ Position row column
2466− where rows = Rope.rows r
2468−genRange :: Rope -> Gen Range
2470− startPos@(Position startLine startColumn) <- genPosition r
2471− let maxLineDiff = max 0 $ rows - 1 - startLine
2472− endLine <- choose (startLine, startLine + maxLineDiff)
2473− let columns = Rope.columns (nthLine endLine r)
2475− if startLine == endLine
2476− then choose (startColumn, columns)
2477− else choose (0, max 0 $ columns - 1)
2478− pure $ Range startPos (Position endLine endColumn)
2479− where rows = Rope.rows r
2481−-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482−nthLine :: Int -> Rope -> Rope
2484− | i < 0 = error $ "Negative line number: " <> show i
2485− | i == 0 && Rope.rows r == 0 = r
2486− | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2487− | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490−getWatchedFilesSubscriptionsUntil = do
2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs