Skip to content

Commit 04e32cd

Browse files
wz1000wz1000
committed
fix hls tests
1 parent d050a2d commit 04e32cd

25 files changed

+241
-256
lines changed

‎ghcide/test/exe/Main.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -87,17 +87,17 @@ import Data.Tuple.Extra
8787
waitForProgressBegin :: Session ()
8888
waitForProgressBegin = void $ skipManyTill anyMessage $ satisfyMaybe $ \case
8989
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just ()
90-
_ -> pure ()
90+
_ -> Nothing
9191

9292
waitForProgressReport :: Session ()
9393
waitForProgressReport = void $ skipManyTill anyMessage $ satisfyMaybe $ \case
9494
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Report _))) -> Just ()
95-
_ -> pure ()
95+
_ -> Nothing
9696

9797
waitForProgressDone :: Session ()
9898
waitForProgressDone = void $ skipManyTill anyMessage $ satisfyMaybe $ \case
9999
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()
100-
_ -> pure ()
100+
_ -> Nothing
101101

102102
main :: IO ()
103103
main = do

‎plugins/hls-eval-plugin/test/Eval.hs‎

Lines changed: 13 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -1,36 +1,23 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE DuplicateRecordFields #-}
34

45
module Eval (
56
tests,
67
) where
78

89
import Control.Applicative.Combinators (
9-
skipManyTill,
10+
skipManyTill
1011
)
12+
import Data.Function
1113
import Control.Monad (when)
1214
import Control.Monad.IO.Class (MonadIO (liftIO))
1315
import qualified Data.Text as T
1416
import qualified Data.Text.IO as T
15-
import Language.Haskell.LSP.Test (
16-
Session,
17-
anyMessage,
18-
documentContents,
19-
executeCommand,
20-
fullCaps,
21-
getCodeLenses,
22-
message,
23-
openDoc,
24-
runSession,
25-
)
26-
import Language.Haskell.LSP.Types (
27-
ApplyWorkspaceEditRequest,
28-
CodeLens (CodeLens, _command, _range),
29-
Command (Command, _title),
30-
Position (..),
31-
Range (..),
32-
TextDocumentIdentifier,
33-
)
17+
import Language.LSP.Test
18+
import Language.LSP.Types
19+
import Language.LSP.Types.Lens (command, title, range)
20+
import Control.Lens (view, _Just, preview)
3421
import System.Directory (doesFileExist)
3522
import System.FilePath (
3623
(<.>),
@@ -58,27 +45,27 @@ tests =
5845
runSession hlsCommand fullCaps evalPath $ do
5946
doc <- openDoc "T1.hs" "haskell"
6047
lenses <- getEvalCodeLenses doc
61-
liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."]
48+
liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."]
6249
, testCase "Produces Refresh code lenses" $
6350
runSession hlsCommand fullCaps evalPath $ do
6451
doc <- openDoc "T2.hs" "haskell"
6552
lenses <- getEvalCodeLenses doc
66-
liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."]
53+
liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."]
6754
, testCase "Code lenses have ranges" $
6855
runSession hlsCommand fullCaps evalPath $ do
6956
doc <- openDoc "T1.hs" "haskell"
7057
lenses <- getEvalCodeLenses doc
71-
liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)]
58+
liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]
7259
, testCase "Multi-line expressions have a multi-line range" $ do
7360
runSession hlsCommand fullCaps evalPath $ do
7461
doc <- openDoc "T3.hs" "haskell"
7562
lenses <- getEvalCodeLenses doc
76-
liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 5 0)]
63+
liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)]
7764
, testCase "Executed expressions range covers only the expression" $ do
7865
runSession hlsCommand fullCaps evalPath $ do
7966
doc <- openDoc "T2.hs" "haskell"
8067
lenses <- getEvalCodeLenses doc
81-
liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)]
68+
liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]
8269
, testCase "Evaluation of expressions" $ goldenTest "T1.hs"
8370
, testCase "Reevaluation of expressions" $ goldenTest "T2.hs"
8471
, testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs"
@@ -214,7 +201,7 @@ getCodeLensesBy f doc = filter f <$> getCodeLenses doc
214201
executeCmd :: Command -> Session ()
215202
executeCmd cmd = do
216203
executeCommand cmd
217-
_resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message
204+
_resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)
218205
-- liftIO $ print _resp
219206
return ()
220207

‎test/functional/Class.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
-- {-# LANGUAGE ViewPatterns #-}
33
{-# LANGUAGE OverloadedStrings #-}
44
{-# LANGUAGE ScopedTypeVariables #-}
5+
{-# LANGUAGE TypeOperators #-}
56
module Class
67
( tests
78
)
@@ -11,9 +12,9 @@ import Control.Lens hiding ((<.>))
1112
import Control.Monad.IO.Class (MonadIO(liftIO))
1213
import qualified Data.ByteString.Lazy as BS
1314
import qualified Data.Text.Encoding as T
14-
import Language.Haskell.LSP.Test
15-
import Language.Haskell.LSP.Types hiding (_title, _command)
16-
import qualified Language.Haskell.LSP.Types.Lens as J
15+
import Language.LSP.Test
16+
import Language.LSP.Types hiding (_title, _command)
17+
import qualified Language.LSP.Types.Lens as J
1718
import System.FilePath
1819
import Test.Hls.Util
1920
import Test.Tasty
@@ -54,10 +55,10 @@ tests = testGroup
5455
executeCodeAction _fAction
5556
]
5657

57-
_CACodeAction :: Prism' CAResult CodeAction
58-
_CACodeAction = prism' CACodeAction $ \case
59-
CACodeAction action -> Just action
60-
_ -> Nothing
58+
_CACodeAction :: Prism' (Command |? CodeAction) CodeAction
59+
_CACodeAction = prism' InR $ \case
60+
InR action -> Just action
61+
_ -> Nothing
6162

6263
classPath :: FilePath
6364
classPath = "test" </> "testdata" </> "class"

‎test/functional/Command.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -5,9 +5,9 @@ import Control.Lens hiding (List)
55
import Control.Monad.IO.Class
66
import qualified Data.Text as T
77
import Data.Char
8-
import Language.Haskell.LSP.Test
9-
import Language.Haskell.LSP.Types as LSP
10-
import Language.Haskell.LSP.Types.Lens as LSP
8+
import Language.LSP.Test
9+
import Language.LSP.Types as LSP
10+
import Language.LSP.Types.Lens as LSP
1111
import Test.Hls.Util
1212
import Test.Tasty
1313
import Test.Tasty.HUnit
@@ -25,8 +25,8 @@ tests = testGroup "commands" [
2525
, testCase "get de-prefixed" $
2626
runSession hlsCommand fullCaps "test/testdata/" $ do
2727
ResponseMessage _ _ (Left err) <- request
28-
WorkspaceExecuteCommand
29-
(ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse
28+
SWorkspaceExecuteCommand
29+
(ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just (List [])))
3030
let ResponseError _ msg _ = err
3131
-- We expect an error message about the dud arguments, but we can
3232
-- check that we found the right plugin.

‎test/functional/Completion.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -5,9 +5,9 @@ module Completion(tests) where
55
import Control.Monad.IO.Class
66
import Control.Lens hiding ((.=))
77
import Data.Aeson (object, (.=))
8-
import Language.Haskell.LSP.Test
9-
import Language.Haskell.LSP.Types
10-
import Language.Haskell.LSP.Types.Lens hiding (applyEdit)
8+
import Language.LSP.Test
9+
import Language.LSP.Types
10+
import Language.LSP.Types.Lens hiding (applyEdit)
1111
import Test.Hls.Util
1212
import Test.Tasty
1313
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
@@ -42,8 +42,8 @@ tests = testGroup "completions" [
4242

4343
compls <- getCompletions doc (Position 5 9)
4444
let item = head $ filter ((== "putStrLn") . (^. label)) compls
45-
resolvedRes <- request CompletionItemResolve item
46-
let Right (resolved :: CompletionItem) = resolvedRes ^. result
45+
resolvedRes <- request SCompletionItemResolve item
46+
let Right resolved = resolvedRes ^. result
4747
liftIO $ print resolved
4848
liftIO $ do
4949
resolved ^. label @?= "putStrLn"
@@ -336,7 +336,7 @@ snippetTests = testGroup "snippets" [
336336

337337
let config = object [ "haskell" .= object ["completionSnippetsOn" .= False]]
338338

339-
sendNotification WorkspaceDidChangeConfiguration
339+
sendNotification SWorkspaceDidChangeConfiguration
340340
(DidChangeConfigurationParams config)
341341

342342
checkNoSnippets doc

‎test/functional/Config.hs‎

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,9 @@ import Data.Default
1111
import qualified Data.Map as Map
1212
import qualified Data.Text as T
1313
import Ide.Plugin.Config
14-
import Language.Haskell.LSP.Test as Test
15-
import Language.Haskell.LSP.Types
16-
import qualified Language.Haskell.LSP.Types.Lens as L
14+
import Language.LSP.Test as Test
15+
import Language.LSP.Types
16+
import qualified Language.LSP.Types.Lens as L
1717
import System.FilePath ((</>))
1818
import Test.Hls.Util
1919
import Test.Tasty
@@ -34,27 +34,27 @@ hlintTests = testGroup "hlint plugin enables" [
3434

3535
testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do
3636
let config = def { hlintOn = True }
37-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
37+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
3838

3939
doc <- openDoc "ApplyRefact2.hs" "haskell"
4040
testHlintDiagnostics doc
4141

4242
let config' = def { hlintOn = False }
43-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
43+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
4444

4545
diags' <- waitForDiagnosticsFrom doc
4646

4747
liftIO $ noHlintDiagnostics diags'
4848

4949
, testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do
5050
let config = def { hlintOn = True }
51-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
51+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
5252

5353
doc <- openDoc "ApplyRefact2.hs" "haskell"
5454
testHlintDiagnostics doc
5555

5656
let config' = pluginGlobalOn config "hlint" False
57-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
57+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
5858

5959
diags' <- waitForDiagnosticsFrom doc
6060

@@ -78,12 +78,12 @@ configTests :: TestTree
7878
configTests = testGroup "config parsing" [
7979
testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do
8080
let config = object []
81-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
81+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
8282

8383
-- Send custom request so server returns a response to prevent blocking
84-
void $ Test.sendRequest (CustomClientMethod "non-existent-method") ()
84+
void $ Test.sendRequest (SCustomMethod "non-existent-method") Null
8585

86-
logNot <- skipManyTill Test.anyMessage Test.message :: Session LogMessageNotification
86+
logNot <- skipManyTill Test.anyMessage (message SWindowLogMessage)
8787

8888
liftIO $ (logNot ^. L.params . L.xtype) > MtError
8989
|| "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message)

‎test/functional/Deferred.hs‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -8,10 +8,10 @@ import Control.Monad.IO.Class
88
import Control.Lens hiding (List)
99
-- import Control.Monad
1010
-- import Data.Maybe
11-
import Language.Haskell.LSP.Test
12-
import Language.Haskell.LSP.Types
13-
import Language.Haskell.LSP.Types.Lens hiding (id, message)
14-
-- import qualified Language.Haskell.LSP.Types.Lens as LSP
11+
import Language.LSP.Test
12+
import Language.LSP.Types
13+
import Language.LSP.Types.Lens hiding (id, message)
14+
-- import qualified Language.LSP.Types.Lens as LSP
1515
import Test.Hls.Util
1616
import Test.Tasty
1717
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
@@ -94,7 +94,7 @@ tests = testGroup "deferred responses" [
9494
testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do
9595
doc <- openDoc "FuncTestFail.hs" "haskell"
9696
defs <- getDefinitions doc (Position 1 11)
97-
liftIO $ defs @?= []
97+
liftIO $ defs @?= InL []
9898

9999
-- TODO: the benefits of caching parsed modules is doubted.
100100
-- TODO: add issue link
@@ -160,16 +160,16 @@ multiMainTests = testGroup "multiple main modules" [
160160
testCase "Can load one file at a time, when more than one Main module exists"
161161
$ runSession hlsCommand fullCaps "test/testdata" $ do
162162
_doc <- openDoc "ApplyRefact2.hs" "haskell"
163-
_diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
164-
diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
163+
_diagsRspHlint <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
164+
diagsRspGhc <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
165165
let (List diags) = diagsRspGhc ^. params . diagnostics
166166

167167
liftIO $ length diags @?= 2
168168

169169
_doc2 <- openDoc "HaReRename.hs" "haskell"
170-
_diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
170+
_diagsRspHlint2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
171171
-- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification
172-
diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
172+
diagsRsp2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
173173
let (List diags2) = diagsRsp2 ^. params . diagnostics
174174

175175
liftIO $ show diags2 @?= "[]"

‎test/functional/Definition.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,9 @@ module Definition (tests) where
22

33
import Control.Lens
44
import Control.Monad.IO.Class
5-
import Language.Haskell.LSP.Test
6-
import Language.Haskell.LSP.Types
7-
import Language.Haskell.LSP.Types.Lens
5+
import Language.LSP.Test
6+
import Language.LSP.Types
7+
import Language.LSP.Types.Lens
88
import System.Directory
99
import Test.Hls.Util
1010
import Test.Tasty
@@ -19,7 +19,7 @@ tests = testGroup "definitions" [
1919
doc <- openDoc "References.hs" "haskell"
2020
defs <- getDefinitions doc (Position 7 8)
2121
let expRange = Range (Position 4 0) (Position 4 3)
22-
liftIO $ defs @?= [Location (doc ^. uri) expRange]
22+
liftIO $ defs @?= InL [Location (doc ^. uri) expRange]
2323

2424
-- -----------------------------------
2525

@@ -29,15 +29,15 @@ tests = testGroup "definitions" [
2929
defs <- getDefinitions doc (Position 2 8)
3030
liftIO $ do
3131
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
32-
defs @?= [Location (filePathToUri fp) zeroRange]
32+
defs @?= InL [Location (filePathToUri fp) zeroRange]
3333

3434
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
3535
testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
3636
doc <- openDoc "Foo.hs" "haskell"
3737
defs <- getDefinitions doc (Position 0 15)
3838
liftIO $ do
3939
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
40-
defs @?= [Location (filePathToUri fp) zeroRange]
40+
defs @?= InL [Location (filePathToUri fp) zeroRange]
4141

4242
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
4343
testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
@@ -46,7 +46,7 @@ tests = testGroup "definitions" [
4646
defs <- getDefinitions doc (Position 2 8)
4747
liftIO $ do
4848
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
49-
defs @?= [Location (filePathToUri fp) zeroRange]
49+
defs @?= InL [Location (filePathToUri fp) zeroRange]
5050

5151
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
5252
testCase "goto's imported modules that are loaded, and then closed" $
@@ -59,7 +59,7 @@ tests = testGroup "definitions" [
5959
liftIO $ putStrLn "D"
6060
liftIO $ do
6161
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
62-
defs @?= [Location (filePathToUri fp) zeroRange]
62+
defs @?= InL [Location (filePathToUri fp) zeroRange]
6363
liftIO $ putStrLn "E" -- AZ
6464

6565
noDiagnostics

‎test/functional/Diagnostic.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,9 @@ import Control.Monad.IO.Class
88
import Data.Aeson (toJSON)
99
import qualified Data.Default
1010
import Ide.Plugin.Config
11-
import Language.Haskell.LSP.Test hiding (message)
12-
import Language.Haskell.LSP.Types
13-
import qualified Language.Haskell.LSP.Types.Lens as LSP
11+
import Language.LSP.Test hiding (message)
12+
import Language.LSP.Types
13+
import qualified Language.LSP.Types.Lens as LSP
1414
import Test.Hls.Util
1515
import Test.Tasty
1616
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
@@ -64,7 +64,7 @@ saveTests = testGroup "only diagnostics on save" [
6464
ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $
6565
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
6666
let config = Data.Default.def { diagnosticsOnChange = False } :: Config
67-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
67+
sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
6868
doc <- openDoc "Hover.hs" "haskell"
6969
diags <- waitForDiagnosticsFrom doc
7070

@@ -75,7 +75,7 @@ saveTests = testGroup "only diagnostics on save" [
7575
_ <- applyEdit doc te
7676
skipManyTill loggingNotification noDiagnostics
7777

78-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
78+
sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing)
7979
diags2 <- waitForDiagnosticsFrom doc
8080
liftIO $
8181
length diags2 @?= 1

0 commit comments

Comments
 (0)