Skip to content

Commit 0b0a6a7

Browse files
peterwicksstringfieldpepeiborrajneiramergify[bot]
authored
Enable more tests (#1143)
* Make rename tests compile. (They can't pass since we don't have a renamer yet.) * Enable some more tests. Co-authored-by: Pepe Iborra <[email protected]> Co-authored-by: Javier Neira <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 93ab0ea commit 0b0a6a7

File tree

10 files changed

+91
-159
lines changed

10 files changed

+91
-159
lines changed

‎test/functional/Command.hs‎

Lines changed: 5 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,7 @@ import Language.Haskell.LSP.Types.Lens as LSP
1111
import Test.Hls.Util
1212
import Test.Tasty
1313
import Test.Tasty.HUnit
14-
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
1514

16-
17-
--TODO : Response Message no longer has 4 inputs
1815
tests :: TestTree
1916
tests = testGroup "commands" [
2017
testCase "are prefixed" $
@@ -25,13 +22,13 @@ tests = testGroup "commands" [
2522
liftIO $ do
2623
all f cmds @? "All prefixed"
2724
not (null cmds) @? "Commands aren't empty"
28-
, ignoreTestBecause "Broken: Plugin package doesn't exist" $
29-
testCase "get de-prefixed" $
25+
, testCase "get de-prefixed" $
3026
runSession hlsCommand fullCaps "test/testdata/" $ do
3127
ResponseMessage _ _ (Left err) <- request
3228
WorkspaceExecuteCommand
33-
(ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse
29+
(ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse
3430
let ResponseError _ msg _ = err
35-
-- We expect an error message about the dud arguments, but should pickup "add" and "package"
36-
liftIO $ (msg `T.isInfixOf` "while parsing args for add in plugin package") @? "Has error message"
31+
-- We expect an error message about the dud arguments, but we can
32+
-- check that we found the right plugin.
33+
liftIO $ "while parsing args for evalCommand in plugin eval" `T.isInfixOf` msg @? "Has error message"
3734
]

‎test/functional/Diagnostic.hs‎

Lines changed: 24 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,7 @@ import Control.Applicative.Combinators
66
import Control.Lens hiding (List)
77
import Control.Monad.IO.Class
88
import Data.Aeson (toJSON)
9-
import qualified Data.Text as T
109
import qualified Data.Default
11-
import Ide.Logger
1210
import Ide.Plugin.Config
1311
import Language.Haskell.LSP.Test hiding (message)
1412
import Language.Haskell.LSP.Types
@@ -22,72 +20,53 @@ import Test.Tasty.HUnit
2220

2321
tests :: TestTree
2422
tests = testGroup "diagnostics providers" [
25-
saveTests
26-
, triggerTests
27-
, errorTests
23+
basicTests
24+
, saveTests
2825
, warningTests
2926
]
3027

31-
32-
triggerTests :: TestTree
33-
triggerTests = testGroup "diagnostics triggers" [
34-
ignoreTestBecause "Broken" $
35-
ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $
36-
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
37-
logm "starting DiagnosticSpec.runs diagnostic on save"
28+
basicTests :: TestTree
29+
basicTests = testGroup "Diagnostics work" [
30+
testCase "hlint produces diagnostics" $
31+
runSession hlsCommand fullCaps "test/testdata/hlint" $ do
3832
doc <- openDoc "ApplyRefact2.hs" "haskell"
39-
40-
diags@(reduceDiag:_) <- waitForDiagnostics
41-
33+
diags <- waitForDiagnosticsFromSource doc "hlint"
34+
reduceDiag <- liftIO $ inspectDiagnostic diags ["Eta reduce"]
35+
redundantID <- liftIO $ inspectDiagnostic diags ["Redundant id"]
4236
liftIO $ do
4337
length diags @?= 2
4438
reduceDiag ^. LSP.range @?= Range (Position 1 0) (Position 1 12)
4539
reduceDiag ^. LSP.severity @?= Just DsInfo
46-
reduceDiag ^. LSP.code @?= Just (StringValue "Eta reduce")
47-
reduceDiag ^. LSP.source @?= Just "hlint"
48-
49-
diags2a <- waitForDiagnostics
50-
51-
liftIO $ length diags2a @?= 2
52-
53-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
54-
55-
diags3@(d:_) <- waitForDiagnosticsSource "eg2"
40+
redundantID ^. LSP.severity @?= Just DsInfo
5641

42+
, testCase "example plugin produces diagnostics" $
43+
runSession hlsCommandExamplePlugin fullCaps "test/testdata/hlint" $ do
44+
doc <- openDoc "ApplyRefact2.hs" "haskell"
45+
diags <- waitForDiagnosticsFromSource doc "example2"
46+
reduceDiag <- liftIO $ inspectDiagnostic diags ["example2 diagnostic, hello world"]
5747
liftIO $ do
58-
length diags3 @?= 1
59-
d ^. LSP.range @?= Range (Position 0 0) (Position 1 0)
60-
d ^. LSP.severity @?= Nothing
61-
d ^. LSP.code @?= Nothing
62-
d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"
63-
]
64-
65-
errorTests :: TestTree
66-
errorTests = testGroup "typed hole errors" [
67-
ignoreTestBecause "Broken" $ testCase "is deferred" $
68-
runSession hlsCommand fullCaps "test/testdata" $ do
69-
_ <- openDoc "TypedHoles.hs" "haskell"
70-
[diag] <- waitForDiagnosticsSource "bios"
71-
liftIO $ diag ^. LSP.severity @?= Just DsWarning
48+
length diags @?= 1
49+
reduceDiag ^. LSP.range @?= Range (Position 0 0) (Position 1 0)
50+
reduceDiag ^. LSP.severity @?= Just DsError
7251
]
7352

7453
warningTests :: TestTree
7554
warningTests = testGroup "Warnings are warnings" [
76-
ignoreTestBecause "Broken" $ testCase "Overrides -Werror" $
55+
testCase "Overrides -Werror" $
7756
runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do
78-
_ <- openDoc "src/WError.hs" "haskell"
79-
[diag] <- waitForDiagnosticsSource "bios"
57+
doc <- openDoc "src/WError.hs" "haskell"
58+
[diag] <- waitForDiagnosticsFrom doc
8059
liftIO $ diag ^. LSP.severity @?= Just DsWarning
8160
]
8261

8362
saveTests :: TestTree
8463
saveTests = testGroup "only diagnostics on save" [
85-
ignoreTestBecause "Broken" $ testCase "Respects diagnosticsOnChange setting" $
64+
ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $
8665
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
8766
let config = Data.Default.def { diagnosticsOnChange = False } :: Config
8867
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
8968
doc <- openDoc "Hover.hs" "haskell"
90-
diags <- waitForDiagnostics
69+
diags <- waitForDiagnosticsFrom doc
9170

9271
liftIO $ do
9372
length diags @?= 0
@@ -97,7 +76,7 @@ saveTests = testGroup "only diagnostics on save" [
9776
skipManyTill loggingNotification noDiagnostics
9877

9978
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
100-
diags2 <- waitForDiagnostics
79+
diags2 <- waitForDiagnosticsFrom doc
10180
liftIO $
10281
length diags2 @?= 1
10382
]

‎test/functional/FunctionalCodeAction.hs‎

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -475,15 +475,24 @@ unusedTermTests = testGroup "unused term code actions" [
475475
doc <- openDoc "CodeActionOnly.hs" "haskell"
476476
_ <- waitForDiagnosticsFrom doc
477477
diags <- getCurrentDiagnostics doc
478-
let params = CodeActionParams doc (Range (Position 2 10) (Position 4 0)) caContext Nothing
478+
let params = CodeActionParams doc (Range (Position 1 0) (Position 4 0)) caContext Nothing
479479
caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline]))
480+
caContextAllActions = CodeActionContext (List diags) Nothing
481+
-- Verify that we get code actions of at least two different kinds.
482+
ResponseMessage _ _ (Right (List allCodeActions))
483+
<- request TextDocumentCodeAction (params & L.context .~ caContextAllActions)
484+
liftIO $ do
485+
redundantId <- inspectCodeAction allCodeActions ["Redundant id"]
486+
redundantId ^. L.kind @?= Just CodeActionQuickFix
487+
unfoldFoo <- inspectCodeAction allCodeActions ["Unfold foo"]
488+
unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline
489+
-- Verify that that when we set the only parameter, we only get actions
490+
-- of the right kind.
480491
ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params
481492
let cas = map fromAction res
482493
kinds = map (^. L.kind) cas
483494
liftIO $ do
484-
-- TODO: When HaRe is back this should be uncommented
485-
-- kinds `shouldNotSatisfy` null
486-
not (any (Just CodeActionRefactorInline /=) kinds) @? "None not CodeActionRefactorInline"
495+
not (null kinds) @? "We found an action of kind RefactorInline"
487496
all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline"
488497
]
489498

‎test/functional/FunctionalLiquid.hs‎

Lines changed: 5 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@ import Control.Lens hiding (List)
66
import Control.Monad.IO.Class
77
import Data.Aeson
88
import Data.Default
9-
import qualified Data.Text as T
109
import Language.Haskell.LSP.Test hiding (message)
1110
import Language.Haskell.LSP.Types as LSP
1211
import Language.Haskell.LSP.Types.Lens as LSP hiding (contents)
@@ -20,83 +19,19 @@ import Test.Tasty.HUnit
2019

2120
tests :: TestTree
2221
tests = testGroup "liquid haskell diagnostics" [
23-
ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, no liquid" $
24-
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
25-
doc <- openDoc "liquid/Evens.hs" "haskell"
26-
27-
diags@(reduceDiag:_) <- waitForDiagnostics
28-
29-
liftIO $ do
30-
length diags @?= 2
31-
reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22)
32-
reduceDiag ^. severity @?= Just DsHint
33-
reduceDiag ^. code @?= Just (StringValue "Use negate")
34-
reduceDiag ^. source @?= Just "hlint"
35-
36-
diags2hlint <- waitForDiagnostics
37-
38-
liftIO $ length diags2hlint @?= 2
39-
40-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
41-
42-
diags3@(d:_) <- waitForDiagnosticsSource "eg2"
43-
44-
liftIO $ do
45-
length diags3 @?= 1
46-
d ^. LSP.range @?= Range (Position 0 0) (Position 1 0)
47-
d ^. LSP.severity @?= Nothing
48-
d ^. LSP.code @?= Nothing
49-
d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"
50-
51-
-- ---------------------------------
52-
53-
, ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, with liquid haskell" $
22+
ignoreTestBecause "no liquid haskell"
23+
$ testCase "liquid haskell generates diagnostics" $
5424
runSession hlsCommand codeActionSupportCaps "test/testdata" $ do
55-
-- runSessionWithConfig logConfig hlsCommand codeActionSupportCaps "test/testdata" $ do
5625
doc <- openDoc "liquid/Evens.hs" "haskell"
5726

58-
diags@(reduceDiag:_) <- waitForDiagnostics
59-
60-
-- liftIO $ show diags @?= ""
61-
62-
liftIO $ do
63-
length diags @?= 2
64-
reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22)
65-
reduceDiag ^. severity @?= Just DsHint
66-
reduceDiag ^. code @?= Just (StringValue "Use negate")
67-
reduceDiag ^. source @?= Just "hlint"
68-
69-
-- Enable liquid haskell plugin and disable hlint
7027
let config = def { liquidOn = True, hlintOn = False }
7128
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
7229

73-
-- docItem <- getDocItem file languageId
74-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
75-
-- TODO: what does that test?
76-
-- TODO: whether hlint is really disbabled?
77-
-- TODO: @fendor, document or remove
78-
-- diags2hlint <- waitForDiagnostics
79-
-- -- liftIO $ show diags2hlint @?= ""
80-
81-
-- -- We turned hlint diagnostics off
82-
-- liftIO $ length diags2hlint @?= 0
83-
-- diags2liquid <- waitForDiagnostics
84-
-- liftIO $ length diags2liquid @?= 0
85-
-- liftIO $ show diags2liquid @?= ""
86-
diags3@(d:_) <- waitForDiagnosticsSource "liquid"
87-
-- liftIO $ show diags3 @?= ""
30+
diags <- waitForDiagnosticsFromSource doc "liquid"
31+
d <- liftIO $ inspectDiagnostic diags ["Liquid Type Mismatch"]
8832
liftIO $ do
89-
length diags3 @?= 1
33+
length diags @?= 1
9034
d ^. range @?= Range (Position 8 0) (Position 8 11)
9135
d ^. severity @?= Just DsError
9236
d ^. code @?= Nothing
93-
d ^. source @?= Just "liquid"
94-
(d ^. message) `T.isPrefixOf`
95-
("Error: Liquid Type Mismatch\n" <>
96-
" Inferred type\n" <>
97-
" VV : {v : GHC.Types.Int | v == 7}\n" <>
98-
" \n" <>
99-
" not a subtype of Required type\n" <>
100-
" VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ")
101-
@? "Contains error message"
10237
]

‎test/functional/HieBios.hs‎

Lines changed: 13 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,36 +1,35 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
module HieBios (tests) where
33

4-
import Control.Applicative.Combinators
4+
import Control.Lens ((^.))
5+
import Control.Monad.IO.Class
56
import qualified Data.Text as T
67
import Language.Haskell.LSP.Test
78
import Language.Haskell.LSP.Types
8-
import Language.Haskell.LSP.Messages
9+
import qualified Language.Haskell.LSP.Types.Lens as L
910
import System.FilePath ((</>))
1011
import Test.Hls.Util
1112
import Test.Tasty
12-
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
1313
import Test.Tasty.HUnit
1414

1515
tests :: TestTree
1616
tests = testGroup "hie-bios" [
17-
ignoreTestBecause "Broken" $ testCase "loads modules inside main-is" $ do
17+
testCase "loads modules inside main-is" $ do
1818
writeFile (hieBiosErrorPath </> "hie.yaml") ""
1919
runSession hlsCommand fullCaps "test/testdata/hieBiosMainIs" $ do
20-
_ <- openDoc "Main.hs" "haskell"
21-
_ <- count 2 waitForDiagnostics
22-
return ()
20+
doc <- openDoc "Main.hs" "haskell"
21+
Just mainHoverText <- getHover doc (Position 3 1)
22+
let (HoverContents (MarkupContent _ x)) = mainHoverText ^. L.contents
23+
liftIO $ "main :: IO ()" `T.isInfixOf` x
24+
@? "found hover text for main"
2325

24-
, ignoreTestBecause "Broken" $ testCase "reports errors in hie.yaml" $ do
26+
, testCase "reports errors in hie.yaml" $ do
2527
writeFile (hieBiosErrorPath </> "hie.yaml") ""
2628
runSession hlsCommand fullCaps hieBiosErrorPath $ do
2729
_ <- openDoc "Foo.hs" "haskell"
28-
_ <- skipManyTill loggingNotification (satisfy isMessage)
29-
return ()
30+
(diag:_) <- waitForDiagnostics
31+
liftIO $ "Expected a cradle: key containing the preferences" `T.isInfixOf` (diag ^. L.message)
32+
@? "Error reported"
3033
]
3134
where
3235
hieBiosErrorPath = "test/testdata/hieBiosError"
33-
34-
isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) =
35-
"Couldn't parse hie.yaml" `T.isInfixOf` s
36-
isMessage _ = False

‎test/functional/Rename.hs‎

Lines changed: 19 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,28 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
module Rename (tests) where
33

4-
-- import Control.Monad.IO.Class
5-
-- import Language.Haskell.LSP.Test
6-
-- import Language.Haskell.LSP.Types
7-
-- import Test.Hls.Util
4+
import Control.Monad.IO.Class (liftIO)
5+
import Language.Haskell.LSP.Test
6+
import Language.Haskell.LSP.Types
7+
import Test.Hls.Util
88
import Test.Tasty
99
import Test.Tasty.HUnit
10+
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
1011

1112
tests :: TestTree
1213
tests = testGroup "rename" [
13-
testCase "works" $ True @?= True
14-
-- pendingWith "removed because of HaRe"
15-
-- runSession hlsCommand fullCaps "test/testdata" $ do
16-
-- doc <- openDoc "Rename.hs" "haskell"
17-
-- rename doc (Position 3 1) "baz" -- foo :: Int -> Int
18-
-- documentContents doc >>= liftIO . flip shouldBe expected
19-
-- where
20-
-- expected =
21-
-- "main = do\n\
22-
-- \ x <- return $ baz 42\n\
23-
-- \ return (baz x)\n\
24-
-- \baz :: Int -> Int\n\
25-
-- \baz x = x + 1\n\
26-
-- \bar = (+ 1) . baz\n"
14+
ignoreTestBecause "no symbol renaming (yet!)" $
15+
testCase "works" $
16+
runSession hlsCommand fullCaps "test/testdata/rename" $ do
17+
doc <- openDoc "Rename.hs" "haskell"
18+
rename doc (Position 3 1) "baz" -- foo :: Int -> Int
19+
contents <- documentContents doc
20+
let expected =
21+
"main = do\n\
22+
\ x <- return $ baz 42\n\
23+
\ return (baz x)\n\
24+
\baz :: Int -> Int\n\
25+
\baz x = x + 1\n\
26+
\bar = (+ 1) . baz\n"
27+
liftIO $ contents @?= expected
2728
]

‎test/testdata/Rename.hs‎ renamed to ‎test/testdata/rename/Rename.hs‎

File renamed without changes.

‎test/testdata/testdata.cabal‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,13 @@ executable codeactionrename
88
main-is: CodeActionRename.hs
99
default-language: Haskell2010
1010

11+
executable codeactiononly
12+
build-depends: base
13+
main-is: CodeActionOnly.hs
14+
default-language: Haskell2010
15+
16+
17+
1118
executable hover
1219
build-depends: base
1320
main-is: Hover.hs

‎test/testdata/wErrorTest/cabal.project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
packages: test.cabal

‎test/testdata/wErrorTest/hie.yaml‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
cradle:
2+
cabal:
3+
- path: "src"
4+
component: "lib:test"

0 commit comments

Comments
 (0)