diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index fde632c7d21..c9614730641 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -87,17 +87,17 @@ import Data.Tuple.Extra waitForProgressBegin :: Session () waitForProgressBegin = void $ skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () - _ -> pure () + _ -> Nothing waitForProgressReport :: Session () waitForProgressReport = void $ skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Report _))) -> Just () - _ -> pure () + _ -> Nothing waitForProgressDone :: Session () waitForProgressDone = void $ skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> pure () + _ -> Nothing main :: IO () main = do diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 4e6b65e2ece..b7e7cdb2fee 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -1,36 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} module Eval ( tests, ) where import Control.Applicative.Combinators ( - skipManyTill, + skipManyTill ) +import Data.Function import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Text as T import qualified Data.Text.IO as T -import Language.Haskell.LSP.Test ( - Session, - anyMessage, - documentContents, - executeCommand, - fullCaps, - getCodeLenses, - message, - openDoc, - runSession, - ) -import Language.Haskell.LSP.Types ( - ApplyWorkspaceEditRequest, - CodeLens (CodeLens, _command, _range), - Command (Command, _title), - Position (..), - Range (..), - TextDocumentIdentifier, - ) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens (command, title, range) +import Control.Lens (view, _Just, preview) import System.Directory (doesFileExist) import System.FilePath ( (<.>), @@ -58,27 +45,27 @@ tests = runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T1.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."] + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T2.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."] + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T1.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T3.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T2.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Evaluation of expressions" $ goldenTest "T1.hs" , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" @@ -214,7 +201,7 @@ getCodeLensesBy f doc = filter f <$> getCodeLenses doc executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) -- liftIO $ print _resp return () diff --git a/test/functional/Class.hs b/test/functional/Class.hs index 4d02ad4e41e..5e4f2e1998c 100644 --- a/test/functional/Class.hs +++ b/test/functional/Class.hs @@ -2,6 +2,7 @@ -- {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Class ( tests ) @@ -11,9 +12,9 @@ import Control.Lens hiding ((<.>)) import Control.Monad.IO.Class (MonadIO(liftIO)) import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types hiding (_title, _command) -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Test +import Language.LSP.Types hiding (_title, _command) +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls.Util import Test.Tasty @@ -54,10 +55,10 @@ tests = testGroup executeCodeAction _fAction ] -_CACodeAction :: Prism' CAResult CodeAction -_CACodeAction = prism' CACodeAction $ \case - CACodeAction action -> Just action - _ -> Nothing +_CACodeAction :: Prism' (Command |? CodeAction) CodeAction +_CACodeAction = prism' InR $ \case + InR action -> Just action + _ -> Nothing classPath :: FilePath classPath = "test" "testdata" "class" diff --git a/test/functional/Command.hs b/test/functional/Command.hs index 61a806801dc..cd39bbf89db 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -5,9 +5,9 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import qualified Data.Text as T import Data.Char -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test +import Language.LSP.Types as LSP +import Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit @@ -25,8 +25,8 @@ tests = testGroup "commands" [ , testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request - WorkspaceExecuteCommand - (ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse + SWorkspaceExecuteCommand + (ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just (List []))) let ResponseError _ msg _ = err -- We expect an error message about the dud arguments, but we can -- check that we found the right plugin. diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index bd8ed721f45..2ff96754e65 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -5,9 +5,9 @@ module Completion(tests) where import Control.Monad.IO.Class import Control.Lens hiding ((.=)) import Data.Aeson (object, (.=)) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding (applyEdit) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (applyEdit) import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -42,8 +42,8 @@ tests = testGroup "completions" [ compls <- getCompletions doc (Position 5 9) let item = head $ filter ((== "putStrLn") . (^. label)) compls - resolvedRes <- request CompletionItemResolve item - let Right (resolved :: CompletionItem) = resolvedRes ^. result + resolvedRes <- request SCompletionItemResolve item + let Right resolved = resolvedRes ^. result liftIO $ print resolved liftIO $ do resolved ^. label @?= "putStrLn" @@ -336,7 +336,7 @@ snippetTests = testGroup "snippets" [ let config = object [ "haskell" .= object ["completionSnippetsOn" .= False]] - sendNotification WorkspaceDidChangeConfiguration + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) checkNoSnippets doc diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 43721fe55ab..09d487f108a 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -11,9 +11,9 @@ import Data.Default import qualified Data.Map as Map import qualified Data.Text as T import Ide.Plugin.Config -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -34,13 +34,13 @@ hlintTests = testGroup "hlint plugin enables" [ testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = def { hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -48,13 +48,13 @@ hlintTests = testGroup "hlint plugin enables" [ , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = pluginGlobalOn config "hlint" False - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -78,12 +78,12 @@ configTests :: TestTree configTests = testGroup "config parsing" [ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do let config = object [] - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) -- Send custom request so server returns a response to prevent blocking - void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + void $ Test.sendRequest (SCustomMethod "non-existent-method") Null - logNot <- skipManyTill Test.anyMessage Test.message :: Session LogMessageNotification + logNot <- skipManyTill Test.anyMessage (message SWindowLogMessage) liftIO $ (logNot ^. L.params . L.xtype) > MtError || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message) diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index 1cec874df87..d3369546881 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -8,10 +8,10 @@ import Control.Monad.IO.Class import Control.Lens hiding (List) -- import Control.Monad -- import Data.Maybe -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding (id, message) --- import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id, message) +-- import qualified Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -94,7 +94,7 @@ tests = testGroup "deferred responses" [ testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTestFail.hs" "haskell" defs <- getDefinitions doc (Position 1 11) - liftIO $ defs @?= [] + liftIO $ defs @?= InL [] -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link @@ -160,16 +160,16 @@ multiMainTests = testGroup "multiple main modules" [ testCase "Can load one file at a time, when more than one Main module exists" $ runSession hlsCommand fullCaps "test/testdata" $ do _doc <- openDoc "ApplyRefact2.hs" "haskell" - _diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification - diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + _diagsRspHlint <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) + diagsRspGhc <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) let (List diags) = diagsRspGhc ^. params . diagnostics liftIO $ length diags @?= 2 _doc2 <- openDoc "HaReRename.hs" "haskell" - _diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + _diagsRspHlint2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification - diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + diagsRsp2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) let (List diags2) = diagsRsp2 ^. params . diagnostics liftIO $ show diags2 @?= "[]" diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index e34a65c0631..ddf5529acd3 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -2,9 +2,9 @@ module Definition (tests) where import Control.Lens import Control.Monad.IO.Class -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens import System.Directory import Test.Hls.Util import Test.Tasty @@ -19,7 +19,7 @@ tests = testGroup "definitions" [ doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) - liftIO $ defs @?= [Location (doc ^. uri) expRange] + liftIO $ defs @?= InL [Location (doc ^. uri) expRange] -- ----------------------------------- @@ -29,7 +29,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -37,7 +37,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 0 15) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -46,7 +46,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded, and then closed" $ @@ -59,7 +59,7 @@ tests = testGroup "definitions" [ liftIO $ putStrLn "D" liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] liftIO $ putStrLn "E" -- AZ noDiagnostics diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index 855a729203e..26ea60616df 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -8,9 +8,9 @@ import Control.Monad.IO.Class import Data.Aeson (toJSON) import qualified Data.Default import Ide.Plugin.Config -import Language.Haskell.LSP.Test hiding (message) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test hiding (message) +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -64,7 +64,7 @@ saveTests = testGroup "only diagnostics on save" [ ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $ runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do let config = Data.Default.def { diagnosticsOnChange = False } :: Config - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "Hover.hs" "haskell" diags <- waitForDiagnosticsFrom doc @@ -75,7 +75,7 @@ saveTests = testGroup "only diagnostics on save" [ _ <- applyEdit doc te skipManyTill loggingNotification noDiagnostics - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing) diags2 <- waitForDiagnosticsFrom doc liftIO $ length diags2 @?= 1 diff --git a/test/functional/Format.hs b/test/functional/Format.hs index e0202c87f87..2651a5d517a 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -5,8 +5,8 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import Test.Hls.Util import Test.Tasty import Test.Tasty.Golden @@ -20,11 +20,11 @@ tests :: TestTree tests = testGroup "format document" [ goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 5 True) + formatDoc doc (FormattingOptions 5 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , rangeTests , providerTests @@ -40,11 +40,11 @@ rangeTests :: TestTree rangeTests = testGroup "format range" [ goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 5 0) (Position 7 10)) + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 5 0) (Position 7 10)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/format/Format.formatted_range_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 5 True) (Range (Position 8 0) (Position 11 19)) + formatRange doc (FormattingOptions 5 True Nothing Nothing Nothing) (Range (Position 8 0) (Position 11 19)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] @@ -54,10 +54,10 @@ providerTests = testGroup "formatting provider" [ doc <- openDoc "Format.hs" "haskell" orig <- documentContents doc - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= orig) - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 1 0) (Position 3 10)) documentContents doc >>= liftIO . (@?= orig) #if AGPL @@ -68,16 +68,16 @@ providerTests = testGroup "formatting provider" [ doc <- openDoc "Format.hs" "haskell" - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittany) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittanyPostFloskell) , testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedBrittany <- liftIO $ T.readFile "test/testdata/format/Format.brittany.formatted.hs" @@ -85,12 +85,12 @@ providerTests = testGroup "formatting provider" [ doc <- openDoc "Format.hs" "haskell" - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittany) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "floskell")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "floskell")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) #endif ] @@ -98,14 +98,14 @@ providerTests = testGroup "formatting provider" [ stylishHaskellTests :: TestTree stylishHaskellTests = testGroup "stylish-haskell" [ goldenVsStringDiff "formats a document" goldenGitDiff "test/testdata/format/StylishHaskell.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) doc <- openDoc "StylishHaskell.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range" goldenGitDiff "test/testdata/format/StylishHaskell.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) doc <- openDoc "StylishHaskell.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 0 0) (Position 2 21)) + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 0 0) (Position 2 21)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] @@ -113,29 +113,29 @@ stylishHaskellTests = testGroup "stylish-haskell" [ brittanyTests :: TestTree brittanyTests = testGroup "brittany" [ goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/format/BrittanyLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyLF.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a document with CRLF endings" goldenGitDiff "test/testdata/format/BrittanyCRLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyCRLF.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range with LF endings" goldenGitDiff "test/testdata/format/BrittanyLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyLF.hs" "haskell" let range = Range (Position 1 0) (Position 2 22) - formatRange doc (FormattingOptions 4 True) range + formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range with CRLF endings" goldenGitDiff "test/testdata/format/BrittanyCRLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyCRLF.hs" "haskell" let range = Range (Position 1 0) (Position 2 22) - formatRange doc (FormattingOptions 4 True) range + formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] #endif @@ -143,28 +143,28 @@ brittanyTests = testGroup "brittany" [ ormoluTests :: TestTree ormoluTests = testGroup "ormolu" [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/format/Format2.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format2.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] fourmoluTests :: TestTree fourmoluTests = testGroup "fourmolu" [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/format/Format2.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format2.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index 1e8082427f4..bca731f9653 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -5,9 +5,9 @@ module FunctionalBadProject (tests) where -- import Control.Lens hiding (List) -- import Control.Monad.IO.Class -- import qualified Data.Text as T --- import Language.Haskell.LSP.Test hiding (message) --- import Language.Haskell.LSP.Types as LSP --- import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error ) +-- import Language.LSP.Test hiding (message) +-- import Language.LSP.Types as LSP +-- import Language.LSP.Types.Lens as LSP hiding (contents, error ) -- import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ca38bbb83a2..02a36e9cb6a 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module FunctionalCodeAction (tests) where @@ -14,10 +15,10 @@ import Data.List import Data.Maybe import qualified Data.Text as T import Ide.Plugin.Config -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Capabilities as C import Test.Hls.Util import Test.Hspec.Expectations @@ -52,7 +53,7 @@ hlintTests = testGroup "hlint suggestions" [ length diags @?= 2 -- "Eta Reduce" and "Redundant Id" reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) reduceDiag ^. L.severity @?= Just DsInfo - reduceDiag ^. L.code @?= Just (StringValue "refact:Eta reduce") + reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" cas <- map fromAction <$> getAllCodeActions doc @@ -85,13 +86,13 @@ hlintTests = testGroup "hlint suggestions" [ , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = def { hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -256,7 +257,7 @@ importTests = testGroup "import suggestions" [ doc <- openDoc "CodeActionImport.hs" "haskell" -- No Formatting: let config = def { formattingProvider = "none" } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) (diag:_) <- waitForDiagnosticsFrom doc liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" @@ -295,7 +296,7 @@ packageTests = testGroup "add package suggestions" [ in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" acts <- getAllCodeActions doc - let (CACodeAction action:_) = acts + let (InR action:_) = acts liftIO $ do action ^. L.title @?= "Add text as a dependency" @@ -373,7 +374,7 @@ redundantImportTests = testGroup "redundant import code actions" [ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - _ : CACommand cmd : _ <- getAllCodeActions doc + _ : InL cmd : _ <- getAllCodeActions doc executeCommand cmd contents <- documentContents doc liftIO $ T.lines contents @?= @@ -550,12 +551,12 @@ unusedTermTests = testGroup "unused term code actions" [ doc <- openDoc "CodeActionOnly.hs" "haskell" _ <- waitForDiagnosticsFrom doc diags <- getCurrentDiagnostics doc - let params = CodeActionParams doc (Range (Position 1 0) (Position 4 0)) caContext Nothing + let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline])) caContextAllActions = CodeActionContext (List diags) Nothing -- Verify that we get code actions of at least two different kinds. ResponseMessage _ _ (Right (List allCodeActions)) - <- request TextDocumentCodeAction (params & L.context .~ caContextAllActions) + <- request STextDocumentCodeAction (params & L.context .~ caContextAllActions) liftIO $ do redundantId <- inspectCodeAction allCodeActions ["Redundant id"] redundantId ^. L.kind @?= Just CodeActionQuickFix @@ -563,7 +564,7 @@ unusedTermTests = testGroup "unused term code actions" [ unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline -- Verify that that when we set the only parameter, we only get actions -- of the right kind. - ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params + ResponseMessage _ _ (Right (List res)) <- request STextDocumentCodeAction params let cas = map fromAction res kinds = map (^. L.kind) cas liftIO $ do @@ -575,4 +576,4 @@ noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = C.CodeActionClientCapabilities (Just True) Nothing + codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs index 8a461d57773..5ecdab96e81 100644 --- a/test/functional/FunctionalLiquid.hs +++ b/test/functional/FunctionalLiquid.hs @@ -6,9 +6,9 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson import Data.Default -import Language.Haskell.LSP.Test hiding (message) -import Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types.Lens as LSP hiding (contents) +import Language.LSP.Test hiding (message) +import Language.LSP.Types as LSP +import Language.LSP.Types.Lens as LSP hiding (contents) import Ide.Plugin.Config import Test.Hls.Util import Test.Tasty @@ -25,7 +25,7 @@ tests = testGroup "liquid haskell diagnostics" [ doc <- openDoc "liquid/Evens.hs" "haskell" let config = def { liquidOn = True, hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) diags <- waitForDiagnosticsFromSource doc "liquid" d <- liftIO $ inspectDiagnostic diags ["Liquid Type Mismatch"] diff --git a/test/functional/HaddockComments.hs b/test/functional/HaddockComments.hs index 9e0378acd8b..acc650575f4 100644 --- a/test/functional/HaddockComments.hs +++ b/test/functional/HaddockComments.hs @@ -2,6 +2,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module HaddockComments ( tests, @@ -14,8 +17,8 @@ import Data.Foldable (find) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import System.FilePath ((<.>), ()) import Test.Hls.Util import Test.Tasty @@ -43,7 +46,7 @@ goldenTest fp (toTitle -> expectedTitle) l c = goldenVsStringDiff (fp <> " (gold _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c)) case find ((== Just expectedTitle) . caTitle) actions of - Just (CACodeAction x) -> do + Just (InR x) -> do executeCodeAction x LBS.fromStrict . encodeUtf8 <$> documentContents doc _ -> liftIO $ assertFailure "Unable to find CodeAction" @@ -65,8 +68,8 @@ toTitle :: GenCommentsType -> Text toTitle Signature = "Generate signature comments" toTitle Record = "Generate fields comments" -caTitle :: CAResult -> Maybe Text -caTitle (CACodeAction CodeAction {_title}) = Just _title +caTitle :: (Command |? CodeAction) -> Maybe Text +caTitle (InR CodeAction {_title}) = Just _title caTitle _ = Nothing haddockCommentsPath :: String diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs index bda0c552a41..a8442b5d4a6 100644 --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -4,9 +4,9 @@ module HieBios (tests) where import Control.Lens ((^.)) import Control.Monad.IO.Class import qualified Data.Text as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs index 14bb24a7686..6457c120a66 100644 --- a/test/functional/Highlight.hs +++ b/test/functional/Highlight.hs @@ -2,8 +2,8 @@ module Highlight (tests) where import Control.Monad.IO.Class -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs index 67f8e9425af..b45aef34a2a 100644 --- a/test/functional/ModuleName.hs +++ b/test/functional/ModuleName.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE DuplicateRecordFields #-} + module ModuleName ( tests ) @@ -9,12 +10,11 @@ where import Control.Applicative.Combinators (skipManyTill) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Text.IO as T -import Language.Haskell.LSP.Test (anyMessage, documentContents, +import Language.LSP.Test (anyMessage, documentContents, executeCommand, fullCaps, getCodeLenses, message, openDoc, runSession) -import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, - CodeLens (..)) +import Language.LSP.Types import System.FilePath ((<.>), ()) import Test.Hls.Util (hlsCommand) import Test.Tasty (TestTree, testGroup) @@ -34,7 +34,7 @@ goldenTest input = runSession hlsCommand fullCaps testdataPath $ do -- getCodeLenses doc >>= liftIO . print . length [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc -- liftIO $ T.writeFile (testdataPath input <.> "expected") edited expected <- liftIO $ T.readFile $ testdataPath input <.> "expected" diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index d674e077da4..07bdf892c13 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -1,6 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Progress (tests) where @@ -13,10 +17,10 @@ import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text, pack) import Ide.Plugin.Config -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -38,29 +42,29 @@ tests = expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"] [evalLens] <- getCodeLenses doc let cmd = evalLens ^?! L.command . _Just - _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing + _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) expectProgressReports ["Evaluating"] , testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] - _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] - _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , ignoreTestBecause "no liquid Haskell support" $ testCase "liquid haskell plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata" $ do doc <- openDoc "liquid/Evens.hs" "haskell" let config = def{liquidOn = True, hlintOn = False} - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing) expectProgressReports ["Running Liquid Haskell on Evens.hs"] ] @@ -71,10 +75,10 @@ progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True))} data CollectedProgressNotification - = CreateM WorkDoneProgressCreateRequest - | BeginM WorkDoneProgressBeginNotification - | ProgressM WorkDoneProgressReportNotification - | EndM WorkDoneProgressEndNotification + = CreateM WorkDoneProgressCreateParams + | BeginM (ProgressParams WorkDoneProgressBeginParams) + | ProgressM (ProgressParams WorkDoneProgressReportParams) + | EndM (ProgressParams WorkDoneProgressEndParams) {- | Test that the server is correctly producing a sequence of progress related messages. Each create must be pair with a corresponding begin and end, @@ -102,10 +106,16 @@ expectProgressReports = expectProgressReports' [] EndM msg -> do liftIO $ token msg `expectElem` tokens expectProgressReports' (delete (token msg) tokens) expectedTitles - title msg = msg ^. L.params ^. L.value ^. L.title - token msg = msg ^. L.params ^. L.token - create = CreateM <$> message - begin = BeginM <$> message - progress = ProgressM <$> message - end = EndM <$> message + title msg = msg ^. L.value ^. L.title + token msg = msg ^. L.token + create = CreateM . view L.params <$> (message SWindowWorkDoneProgressCreate) + begin = BeginM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) + _ -> Nothing) + progress = ProgressM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) + _ -> Nothing) + end = EndM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) + _ -> Nothing) expectElem a as = a `elem` as @? "Unexpected " ++ show a diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index fbe2ce23307..c4718e7e350 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -3,13 +3,14 @@ module Reference (tests) where import Control.Lens import Control.Monad.IO.Class import Data.List -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit +import Data.Coerce tests :: TestTree tests = testGroup "references" [ @@ -24,7 +25,7 @@ tests = testGroup "references" [ , mkRange 4 14 4 17 , mkRange 4 0 4 3 , mkRange 2 6 2 9 - ] `isInfixOf` refs @? "Contains references" + ] `isInfixOf` (coerce refs) @? "Contains references" -- TODO: Respect withDeclaration parameter -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do -- doc <- openDoc "References.hs" "haskell" diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs index bcd9a65a627..576bbaf6c8c 100644 --- a/test/functional/Rename.hs +++ b/test/functional/Rename.hs @@ -2,8 +2,8 @@ module Rename (tests) where import Control.Monad.IO.Class (liftIO) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index e5fdca04687..a0c5f02e650 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -2,6 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} module Splice (tests) where @@ -13,16 +16,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Splice.Types -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types - ( ApplyWorkspaceEditRequest, - CAResult (..), - CodeAction (..), - Position (..), - Range (..), - TextDocumentContentChangeEvent (..), - TextEdit (..), - ) +import Language.LSP.Test +import Language.LSP.Types import System.Directory import System.FilePath import System.Time.Extra (sleep) @@ -77,9 +72,9 @@ goldenTest input tc line col = _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of - Just (CACodeAction CodeAction {_command = Just c}) -> do + Just (InR CodeAction {_command = Just c}) -> do executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = spliceTestPath input <.> "expected" -- Write golden tests if they don't already exist @@ -110,9 +105,9 @@ goldenTestWithEdit input tc line col = void waitForDiagnostics actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of - Just (CACodeAction CodeAction {_command = Just c}) -> do + Just (InR CodeAction {_command = Just c}) -> do executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = spliceTestPath input <.> "expected" -- Write golden tests if they don't already exist @@ -134,6 +129,6 @@ pointRange Range (Position line col) (Position line $ col + 1) -- | Get the title of a code action. -codeActionTitle :: CAResult -> Maybe Text -codeActionTitle CACommand {} = Nothing -codeActionTitle (CACodeAction (CodeAction title _ _ _ _)) = Just title +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index bda453841f7..04af41ede04 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -4,10 +4,10 @@ module Symbol (tests) where import Control.Lens (to, ix, (^?), _Just) import Control.Monad.IO.Class import Data.List -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import Language.LSP.Types.Capabilities import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index 5a3bbed4d6b..b0654aabae1 100644 --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} module Tactic ( tests @@ -19,9 +22,9 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Tactic.TestTypes -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types (ExecuteCommandParams(ExecuteCommandParams), ClientMethod (..), Command, ExecuteCommandResponse, ResponseMessage (..), ApplyWorkspaceEditRequest, Position(..) , Range(..) , CAResult(..) , CodeAction(..)) -import Language.Haskell.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename) import System.Directory (doesFileExist) import System.FilePath import Test.Hls.Util @@ -44,9 +47,9 @@ pointRange ------------------------------------------------------------------------------ -- | Get the title of a code action. -codeActionTitle :: CAResult -> Maybe Text -codeActionTitle CACommand{} = Nothing -codeActionTitle (CACodeAction(CodeAction title _ _ _ _)) = Just title +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title tests :: TestTree @@ -153,10 +156,10 @@ goldenTest input line col tc occ = doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) + Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = tacticPath input <.> "expected" -- Write golden tests if they don't already exist @@ -173,7 +176,7 @@ expectFail input line col tc occ = doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) + Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions resp <- executeCommandWithResp c liftIO $ unless (isLeft $ _result resp) $ @@ -184,8 +187,8 @@ tacticPath :: FilePath tacticPath = "test/testdata/tactic" -executeCommandWithResp :: Command -> Session ExecuteCommandResponse +executeCommandWithResp :: Command -> Session (ResponseMessage WorkspaceExecuteCommand) executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args Nothing - request WorkspaceExecuteCommand execParams + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + request SWorkspaceExecuteCommand execParams diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index c1b6e7e7b25..4bf49efb84c 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -2,8 +2,8 @@ module TypeDefinition (tests) where import Control.Monad.IO.Class import Data.Tuple.Extra (first3) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -38,7 +38,7 @@ getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = failIfSessionTimeout . runSession (hlsCommand ++ " --test") fullCaps definitionsPath $ do doc <- openDoc symbolFile "haskell" - defs <- getTypeDefinitions doc $ Position symbolLine symbolCol + InL defs <- getTypeDefinitions doc $ Position symbolLine symbolCol liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations getTypeDefinitionTest' :: Int -> Int -> Int -> Int -> Assertion diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 2e27cc3cd5d..3d3b85c6e42 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses, DuplicateRecordFields, TypeOperators, GADTs #-} +{-# LANGUAGE FlexibleContexts #-} module Test.Hls.Util ( codeActionSupportCaps - , dummyLspFuncs , expectCodeAction , expectDiagnostic , expectNoMoreDiagnostics @@ -36,6 +36,7 @@ module Test.Hls.Util ) where +import qualified Data.Aeson as A import Control.Exception (throwIO, catch) import Control.Monad import Control.Monad.IO.Class @@ -47,12 +48,10 @@ import Data.List.Extra (find) import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Test as Test -import qualified Language.Haskell.LSP.Types.Lens as L -import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.LSP.Types hiding (Reason(..)) +import qualified Language.LSP.Test as Test +import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Capabilities as C import System.Directory import System.Environment import System.Time.Extra (Seconds, sleep) @@ -72,8 +71,8 @@ codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport) - literalSupport = C.CodeActionLiteralSupport def + codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) + literalSupport = CodeActionLiteralSupport def -- --------------------------------------------------------------------- @@ -292,22 +291,6 @@ flushStackEnvironment = do -- --------------------------------------------------------------------- -dummyLspFuncs :: Default a => LspFuncs a -dummyLspFuncs = LspFuncs { clientCapabilities = def - , config = return (Just def) - , sendFunc = const (return ()) - , getVirtualFileFunc = const (return Nothing) - , persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri)) - , reverseFileMapFunc = return id - , publishDiagnosticsFunc = mempty - , flushDiagnosticsBySourceFunc = mempty - , getNextReqId = pure (IdInt 0) - , rootPath = Nothing - , getWorkspaceFolders = return Nothing - , withProgress = \_ _ f -> f (const (return ())) - , withIndefiniteProgress = \_ _ f -> f - } - -- | Like 'withCurrentDirectory', but will copy the directory over to the system -- temporary directory first to avoid haskell-language-server's source tree from -- interfering with the cradle @@ -335,12 +318,12 @@ copyDir src dst = do else copyFile srcFp dstFp where ignored = ["dist", "dist-newstyle", ".stack-work"] -fromAction :: CAResult -> CodeAction -fromAction (CACodeAction action) = action +fromAction :: (Command |? CodeAction) -> CodeAction +fromAction (InR action) = action fromAction _ = error "Not a code action" -fromCommand :: CAResult -> Command -fromCommand (CACommand command) = command +fromCommand :: (Command |? CodeAction) -> Command +fromCommand (InL command) = command fromCommand _ = error "Not a command" onMatch :: [a] -> (a -> Bool) -> String -> IO a @@ -353,24 +336,24 @@ inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.me expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () expectDiagnostic diags s = void $ inspectDiagnostic diags s -inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction +inspectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO CodeAction inspectCodeAction cars s = fromAction <$> onMatch cars predicate err - where predicate (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s + where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" -expectCodeAction :: [CAResult] -> [T.Text] -> IO () +expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO () expectCodeAction cars s = void $ inspectCodeAction cars s -inspectCommand :: [CAResult] -> [T.Text] -> IO Command +inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command inspectCommand cars s = fromCommand <$> onMatch cars predicate err - where predicate (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s + where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) let (List diags) = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc @@ -378,7 +361,7 @@ waitForDiagnosticsFrom doc = do waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic] waitForDiagnosticsFromSource doc src = do - diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) let (List diags) = diagsNot ^. L.params . L.diagnostics let res = filter matches diags if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res @@ -408,7 +391,7 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + void $ Test.sendRequest (SCustomMethod "non-existent-method") A.Null handleMessages where matches :: Diagnostic -> Bool @@ -416,7 +399,7 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers handleDiagnostic = do - diagsNot <- Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- Test.message STextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri (List diags) = diagsNot ^. L.params . L.diagnostics res = filter matches diags @@ -427,8 +410,9 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do -- handle that and then exit void (Test.satisfyMaybe responseForNonExistentMethod) >> return [] + responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage responseForNonExistentMethod notif - | NotLogMessage logMsg <- notif, + | FromServerMess SWindowLogMessage logMsg <- notif, "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif | otherwise = Nothing