lsp-test 0.14.1.0 → 0.15.0.0
raw patch · 14 files changed
+644/−622 lines, 14 filesdep +row-typesdep −unordered-containersdep ~conduit-parsedep ~containersdep ~lsp
Dependencies added: row-types
Dependencies removed: unordered-containers
Dependency ranges changed: conduit-parse, containers, lsp, lsp-types, parser-combinators
Files
- ChangeLog.md +4/−0
- bench/SimpleBench.hs +19/−16
- example/Test.hs +3/−2
- func-test/FuncTest.hs +15/−20
- lsp-test.cabal +130/−111
- src/Language/LSP/Test.hs +154/−161
- src/Language/LSP/Test/Compat.hs +9/−5
- src/Language/LSP/Test/Decoding.hs +5/−7
- src/Language/LSP/Test/Exceptions.hs +2/−2
- src/Language/LSP/Test/Files.hs +42/−38
- src/Language/LSP/Test/Parsing.hs +34/−28
- src/Language/LSP/Test/Session.hs +61/−56
- test/DummyServer.hs +95/−91
- test/Test.hs +71/−85
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.15.0.0++* Support `lsp-types-2.0.0.0` and `lsp-2.0.0.0`.+ ## 0.14.1.0 * Compatibility with new `lsp-types` major version.
bench/SimpleBench.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs, OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-} module Main where import Language.LSP.Server import qualified Language.LSP.Test as Test-import Language.LSP.Types+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message import Control.Monad.IO.Class import Control.Monad-import System.Process+import System.Process hiding (env) import System.Environment import System.Time.Extra import Control.Concurrent@@ -15,16 +18,16 @@ handlers :: Handlers (LspM ()) handlers = mconcat- [ requestHandler STextDocumentHover $ \req responder -> do- let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req+ [ requestHandler SMethod_TextDocumentHover $ \req responder -> do+ let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req Position _l _c' = pos rsp = Hover ms (Just range)- ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world"+ ms = InL $ mkMarkdown "Hello world" range = Range pos pos- responder (Right $ Just rsp)- , requestHandler STextDocumentDefinition $ \req responder -> do- let RequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req- responder (Right $ InL $ Location doc $ Range pos pos)+ responder (Right $ InL rsp)+ , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do+ let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req+ responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos) ] server :: ServerDefinition ()@@ -44,19 +47,19 @@ n <- read . head <$> getArgs - forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server+ _ <- forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server liftIO $ putStrLn $ "Starting " <> show n <> " rounds" - i <- newIORef 0+ i <- newIORef (0 :: Integer) Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do start <- liftIO offsetTime replicateM_ n $ do- n <- liftIO $ readIORef i- liftIO $ when (n `mod` 1000 == 0) $ putStrLn $ show n- ResponseMessage{_result=Right (Just _)} <- Test.request STextDocumentHover $+ v <- liftIO $ readIORef i+ liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v+ TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $ HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing- ResponseMessage{_result=Right (InL _)} <- Test.request STextDocumentDefinition $+ TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $ DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing liftIO $ modifyIORef' i (+1)
example/Test.hs view
@@ -2,7 +2,8 @@ import Control.Applicative.Combinators import Control.Monad.IO.Class import Language.LSP.Test-import Language.LSP.Types+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do doc <- openDoc "Rename.hs" "haskell"@@ -11,7 +12,7 @@ skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) -- Send requests and notifications and receive responses- rsp <- request STextDocumentDocumentSymbol $+ rsp <- request SMethod_TextDocumentDocumentSymbol $ DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp
func-test/FuncTest.hs view
@@ -4,8 +4,9 @@ import Language.LSP.Server import qualified Language.LSP.Test as Test-import Language.LSP.Types-import Language.LSP.Types.Lens hiding (options)+import Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message import Control.Monad.IO.Class import System.IO import Control.Monad@@ -41,7 +42,7 @@ handlers :: MVar () -> Handlers (LspM ()) handlers killVar =- notificationHandler SInitialized $ \noti -> do+ notificationHandler SMethod_Initialized $ \noti -> do tid <- withRunInIO $ \runInIO -> forkIO $ runInIO $ withProgress "Doing something" NotCancellable $ \updater ->@@ -55,20 +56,16 @@ Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do- x <- Test.message SProgress- let isBegin (Begin _) = True- isBegin _ = False- guard $ isBegin $ x ^. params . value+ x <- Test.message SMethod_Progress+ guard $ has (L.params . L.value . _workDoneProgressBegin) x -- Then kill the thread liftIO $ putMVar killVar () -- Then make sure we still get a $/progress end notification skipManyTill Test.anyMessage $ do- x <- Test.message SProgress- let isEnd (End _) = True- isEnd _ = False- guard $ isEnd $ x ^. params . value+ x <- Test.message SMethod_Progress+ guard $ has (L.params . L.value . _workDoneProgressEnd) x describe "workspace folders" $ it "keeps track of open workspace folders" $ do@@ -77,9 +74,9 @@ countVar <- newMVar 0 - let wf0 = WorkspaceFolder "one" "Starter workspace"- wf1 = WorkspaceFolder "/foo/bar" "My workspace"- wf2 = WorkspaceFolder "/foo/baz" "My other workspace"+ let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace"+ wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace"+ wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace" definition = ServerDefinition { onConfigurationChange = const $ const $ Right ()@@ -92,10 +89,10 @@ handlers :: Handlers (LspM ()) handlers = mconcat- [ notificationHandler SInitialized $ \noti -> do+ [ notificationHandler SMethod_Initialized $ \noti -> do wfs <- fromJust <$> getWorkspaceFolders liftIO $ wfs `shouldContain` [wf0]- , notificationHandler SWorkspaceDidChangeWorkspaceFolders $ \noti -> do+ , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) wfs <- fromJust <$> getWorkspaceFolders liftIO $ case i of@@ -116,11 +113,9 @@ } changeFolders add rmv =- let addedFolders = List add- removedFolders = List rmv- ev = WorkspaceFoldersChangeEvent addedFolders removedFolders+ let ev = WorkspaceFoldersChangeEvent add rmv ps = DidChangeWorkspaceFoldersParams ev- in Test.sendNotification SWorkspaceDidChangeWorkspaceFolders ps+ in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do changeFolders [wf1] []
lsp-test.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.4-name: lsp-test-version: 0.14.1.0-synopsis: Functional test framework for LSP servers.+cabal-version: 2.4+name: lsp-test+version: 0.15.0.0+synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against <https://microsoft.github.io/language-server-protocol/ Language Server Protocol servers>.@@ -10,126 +10,145 @@ To see examples of it in action, check out <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>, <https://github.com/haskell/haskell-language-server haskell-language-server> and <https://github.com/digital-asset/ghcide ghcide>.-homepage: https://github.com/haskell/lsp/blob/master/lsp-test/README.md-license: BSD-3-Clause-license-file: LICENSE-author: Luke Lau-maintainer: luke_lau@icloud.com-bug-reports: https://github.com/haskell/lsp/issues-copyright: 2021 Luke Lau-category: Testing-build-type: Simple-extra-source-files: README.md- , ChangeLog.md- , test/data/**/*.hs-tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2 +homepage:+ https://github.com/haskell/lsp/blob/master/lsp-test/README.md++license: BSD-3-Clause+license-file: LICENSE+author: Luke Lau+maintainer: luke_lau@icloud.com+bug-reports: https://github.com/haskell/lsp/issues+copyright: 2021 Luke Lau+category: Testing+build-type: Simple+extra-source-files:+ ChangeLog.md+ README.md+ test/data/**/*.hs+ source-repository head type: git location: https://github.com/haskell/lsp library- hs-source-dirs: src- exposed-modules: Language.LSP.Test- reexported-modules: lsp-types:Language.LSP.Types- , lsp-types:Language.LSP.Types.Capabilities- , parser-combinators:Control.Applicative.Combinators- default-language: Haskell2010- build-depends: base >= 4.10 && < 5- , lsp-types == 1.5.* || == 1.6.*- , lsp == 1.5.* || == 1.6.*- , aeson- , time- , aeson-pretty- , ansi-terminal- , async >= 2.0- , bytestring- , co-log-core- , conduit- , conduit-parse == 0.2.*- , containers >= 0.5.9- , data-default- , Diff >= 0.3- , directory- , exceptions- , filepath- , Glob >= 0.9 && < 0.11- , lens- , mtl < 2.4- , parser-combinators >= 1.2- , process >= 1.6- , text- , transformers- , unordered-containers- , some+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Language.LSP.Test+ reexported-modules:+ lsp-types:Language.LSP.Protocol.Types+ , lsp-types:Language.LSP.Protocol.Message+ , lsp-types:Language.LSP.Protocol.Capabilities+ , parser-combinators:Control.Applicative.Combinators++ build-depends:+ , aeson+ , aeson-pretty+ , ansi-terminal+ , async >=2.0+ , base >=4.10 && <5+ , bytestring+ , co-log-core+ , conduit+ , conduit-parse ^>=0.2+ , containers >=0.5.9+ , data-default+ , Diff >=0.3+ , directory+ , exceptions+ , filepath+ , Glob >=0.9 && <0.11+ , lens+ , lsp ^>=2.0+ , lsp-types ^>=2.0+ , mtl <2.4+ , parser-combinators >=1.2+ , process >=1.6+ , row-types+ , some+ , text+ , time+ , transformers+ if os(windows)- build-depends: Win32+ build-depends: Win32 else- build-depends: unix- other-modules: Language.LSP.Test.Compat- Language.LSP.Test.Decoding- Language.LSP.Test.Exceptions- Language.LSP.Test.Files- Language.LSP.Test.Parsing- Language.LSP.Test.Server- Language.LSP.Test.Session- ghc-options: -W+ build-depends: unix + other-modules:+ Language.LSP.Test.Compat+ Language.LSP.Test.Decoding+ Language.LSP.Test.Exceptions+ Language.LSP.Test.Files+ Language.LSP.Test.Parsing+ Language.LSP.Test.Server+ Language.LSP.Test.Session++ ghc-options: -W+ test-suite tests- type: exitcode-stdio-1.0- main-is: Test.hs- other-modules: DummyServer- hs-source-dirs: test- ghc-options: -W- build-depends: base >= 4.10 && < 5- , hspec- , lens- , lsp == 1.6.*- , lsp-test- , data-default- , aeson- , unordered-containers- , text- , directory- , filepath- , unliftio- , process- , mtl < 2.4- , aeson- default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ default-language: Haskell2010+ ghc-options: -W+ other-modules: DummyServer+ build-depends:+ , aeson+ , base >=4.10 && <5+ , containers+ , data-default+ , directory+ , filepath+ , hspec+ , lens+ , lsp ^>=2.0+ , lsp-test+ , mtl <2.4+ , parser-combinators+ , process+ , text+ , unliftio + test-suite func-test- main-is: FuncTest.hs- hs-source-dirs: func-test- type: exitcode-stdio-1.0- build-depends: base- , lsp-test- , lsp- , process- , co-log-core- , lens- , unliftio- , hspec- default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: func-test+ default-language: Haskell2010+ main-is: FuncTest.hs+ build-depends:+ , base+ , co-log-core+ , hspec+ , lens+ , lsp+ , lsp-test+ , parser-combinators+ , process+ , unliftio + test-suite example- main-is: Test.hs- hs-source-dirs: example- type: exitcode-stdio-1.0- default-language: Haskell2010- build-depends: base- , lsp-test- , parser-combinators- build-tool-depends: lsp:lsp-demo-reactor-server+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ default-language: Haskell2010+ main-is: Test.hs+ build-depends:+ , base+ , lsp-test+ , parser-combinators+ build-tool-depends: lsp:lsp-demo-reactor-server benchmark simple-bench- main-is: SimpleBench.hs- hs-source-dirs: bench- type: exitcode-stdio-1.0- build-depends: base- , lsp-test- , lsp- , process- , extra- default-language: Haskell2010- ghc-options: -Wall -O2 -eventlog -rtsopts+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ default-language: Haskell2010+ main-is: SimpleBench.hs+ ghc-options: -Wall -O2 -eventlog -rtsopts+ build-depends:+ , base+ , extra+ , lsp+ , lsp-test+ , process+
src/Language/LSP/Test.hs view
@@ -113,16 +113,14 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Aeson+import Data.Aeson hiding (Null) import Data.Default-import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Maybe-import Language.LSP.Types-import Language.LSP.Types.Lens hiding- (id, capabilities, message, executeCommand, applyEdit, rename, to)-import qualified Language.LSP.Types.Lens as LSP-import qualified Language.LSP.Types.Capabilities as C+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Lens as L+import qualified Language.LSP.Protocol.Capabilities as C import Language.LSP.VFS import Language.LSP.Test.Compat import Language.LSP.Test.Decoding@@ -147,7 +145,7 @@ -- > params = TextDocumentPositionParams doc -- > hover <- request STextdocumentHover params runSession :: String -- ^ The command to run the server.- -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+ -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a@@ -156,7 +154,7 @@ -- | Starts a new session with a custom configuration. runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. -> String -- ^ The command to run the server.- -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+ -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a@@ -166,7 +164,7 @@ runSessionWithConfigCustomProcess :: (CreateProcess -> CreateProcess) -- ^ Tweak the 'CreateProcess' used to start the server. -> SessionConfig -- ^ Configuration options for the session. -> String -- ^ The command to run the server.- -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+ -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a@@ -188,7 +186,7 @@ runSessionWithHandles :: Handle -- ^ The input handle -> Handle -- ^ The output handle -> SessionConfig- -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+ -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a@@ -199,7 +197,7 @@ -> Handle -- ^ The input handle -> Handle -- ^ The output handle -> SessionConfig- -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+ -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a@@ -212,32 +210,33 @@ let initializeParams = InitializeParams Nothing -- Narrowing to Int32 here, but it's unlikely that a PID will -- be outside the range- (Just $ fromIntegral pid)+ (InL $ fromIntegral pid) (Just lspTestClientInfo) (Just $ T.pack absRootDir)- (Just $ filePathToUri absRootDir)- (lspConfig config')+ Nothing+ (InL $ filePathToUri absRootDir) caps- (Just TraceOff)- (List <$> initialWorkspaceFolders config)+ (lspConfig config')+ (Just TraceValues_Off)+ (fmap InL $ initialWorkspaceFolders config) runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls- initReqId <- sendRequest SInitialize initializeParams+ initReqId <- sendRequest SMethod_Initialize initializeParams -- Because messages can be sent in between the request and response, -- collect them and then...- (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)+ (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SMethod_Initialize initReqId) - case initRspMsg ^. LSP.result of+ case initRspMsg ^. L.result of Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) Right _ -> pure () initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg- sendNotification SInitialized (Just InitializedParams)+ sendNotification SMethod_Initialized InitializedParams case lspConfig config of- Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)+ Just cfg -> sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) Nothing -> return () -- ... relay them back to the user Session so they can match on them!@@ -251,7 +250,7 @@ where -- | Asks the server to shutdown and exit politely exitServer :: Session ()- exitServer = request_ SShutdown Empty >> sendNotification SExit Empty+ exitServer = request_ SMethod_Shutdown Nothing >> sendNotification SMethod_Exit Nothing -- | Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores@@ -264,17 +263,17 @@ writeChan (messageChan context) (ServerMessage msg) case msg of- (FromServerRsp SShutdown _) -> return ()+ (FromServerRsp SMethod_Shutdown _) -> return () _ -> listenServer serverOut context -- | Is this message allowed to be sent by the server between the intialize -- request and response? -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize checkLegalBetweenMessage :: FromServerMessage -> Session ()- checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure ()- checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure ()- checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure ()- checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure ()+ checkLegalBetweenMessage (FromServerMess SMethod_WindowShowMessage _) = pure ()+ checkLegalBetweenMessage (FromServerMess SMethod_WindowLogMessage _) = pure ()+ checkLegalBetweenMessage (FromServerMess SMethod_TelemetryEvent _) = pure ()+ checkLegalBetweenMessage (FromServerMess SMethod_WindowShowMessageRequest _) = pure () checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg) -- | Check environment variables to override the config@@ -292,14 +291,14 @@ documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get- let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. uri))+ let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri)) return (virtualFileText file) -- | Parses an ApplyEditRequest, checks that it is for the passed document -- and returns the new content getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do- req <- message SWorkspaceApplyEdit+ req <- message SMethod_WorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $ liftIO $ throw (IncorrectApplyEditRequest (show req))@@ -307,14 +306,14 @@ documentContents doc where checkDocumentChanges req =- let changes = req ^. params . edit . documentChanges+ let changes = req ^. L.params . L.edit . L.documentChanges maybeDocs = fmap (fmap documentChangeUri) changes in case maybeDocs of- Just docs -> (doc ^. uri) `elem` docs+ Just docs -> (doc ^. L.uri) `elem` docs Nothing -> False checkChanges req =- let mMap = req ^. params . edit . changes- in maybe False (HashMap.member (doc ^. uri)) mMap+ let mMap = req ^. L.params . L.edit . L.changes+ in maybe False (Map.member (doc ^. L.uri)) mMap -- | Sends a request to the server and waits for its response. -- Will skip any messages in between the request and the response@@ -322,11 +321,11 @@ -- rsp <- request STextDocumentDocumentSymbol params -- @ -- Note: will skip any messages in between the request and the response.-request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)+request :: SClientMethod m -> MessageParams m -> Session (TResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId m -- | The same as 'sendRequest', but discard the response.-request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()+request_ :: SClientMethod (m :: Method ClientToServer Request) -> MessageParams m -> Session () request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.@@ -339,7 +338,7 @@ modify $ \c -> c { curReqId = idn+1 } let id = IdInt idn - let mess = RequestMessage "2.0" id method params+ let mess = TRequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask@@ -353,27 +352,27 @@ return id -- | Sends a notification to the server.-sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method.+sendNotification :: SClientMethod (m :: Method ClientToServer Notification) -- ^ The notification method. -> MessageParams m -- ^ The notification parameters. -> Session () -- Open a virtual file if we send a did open text document notification-sendNotification STextDocumentDidOpen params = do- let n = NotificationMessage "2.0" STextDocumentDidOpen params+sendNotification SMethod_TextDocumentDidOpen params = do+ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ openVFS mempty n modify (\s -> s { vfs = newVFS }) sendMessage n -- Close a virtual file if we send a close text document notification-sendNotification STextDocumentDidClose params = do- let n = NotificationMessage "2.0" STextDocumentDidClose params+sendNotification SMethod_TextDocumentDidClose params = do+ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidClose params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ closeVFS mempty n modify (\s -> s { vfs = newVFS }) sendMessage n -sendNotification STextDocumentDidChange params = do- let n = NotificationMessage "2.0" STextDocumentDidChange params+sendNotification SMethod_TextDocumentDidChange params = do+ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidChange params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n modify (\s -> s { vfs = newVFS })@@ -381,17 +380,17 @@ sendNotification method params = case splitClientMethod method of- IsClientNot -> sendMessage (NotificationMessage "2.0" method params)- IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params)+ IsClientNot -> sendMessage (TNotificationMessage "2.0" method params)+ IsClientEither -> sendMessage (NotMess $ TNotificationMessage "2.0" method params) -- | Sends a response to the server.-sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session ()+sendResponse :: (ToJSON (MessageResult m), ToJSON (ErrorData m)) => TResponseMessage m -> Session () sendResponse = sendMessage -- | Returns the initialize response that was received from the server. -- The initialize requests and responses are not included the session, -- so if you need to test it use this.-initializeResponse :: Session (ResponseMessage Initialize)+initializeResponse :: Session (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp -- | /Creates/ a new text document. This is different from 'openDoc'@@ -412,14 +411,16 @@ rootDir <- asks rootDir caps <- asks sessionCapabilities absFile <- liftIO $ canonicalizePath (rootDir </> file)- let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles]- pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]+ let pred :: SomeRegistration -> [TRegistration Method_WorkspaceDidChangeWatchedFiles]+ pred (SomeRegistration r@(TRegistration _ SMethod_WorkspaceDidChangeWatchedFiles _)) = [r] pred _ = mempty regs = concatMap pred $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool- watchHits (FileSystemWatcher pattern kind) =+ watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) = -- If WatchKind is excluded, defaults to all true as per spec- fileMatches (T.unpack pattern) && createHits (fromMaybe (WatchKind True True True) kind)+ fileMatches (T.unpack pattern) && containsCreate (fromMaybe WatchKind_Create kind)+ -- TODO: Relative patterns+ watchHits _ = False fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs -- If the pattern is absolute then match against the absolute fp@@ -427,19 +428,17 @@ | isAbsolute pattern = absFile | otherwise = file - createHits (WatchKind create _ _) = create-- regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool- regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers)+ regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool+ regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers) clientCapsSupports =- caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just+ caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs when shouldSend $- sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]+ sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+ [ FileEvent (filePathToUri (rootDir </> file)) FileChangeType_Created ] openDoc' file languageId contents -- | Opens a text document that /exists on disk/, and sends a@@ -459,21 +458,21 @@ let fp = rootDir context </> file uri = filePathToUri fp item = TextDocumentItem uri languageId 0 contents- sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)+ sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) pure $ TextDocumentIdentifier uri -- | Closes a text document and sends a textDocument/didOpen notification to the server. closeDoc :: TextDocumentIdentifier -> Session () closeDoc docId = do- let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))- sendNotification STextDocumentDidClose params+ let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. L.uri))+ sendNotification SMethod_TextDocumentDidClose params -- | Changes a text document and sends a textDocument/didOpen notification to the server. changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () changeDoc docId changes = do verDoc <- getVersionedDoc docId- let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)- sendNotification STextDocumentDidChange params+ let params = DidChangeTextDocumentParams (verDoc & L.version +~ 1) changes+ sendNotification SMethod_TextDocumentDidChange params -- | Gets the Uri for the file corrected to the session directory. getDocUri :: FilePath -> Session Uri@@ -485,8 +484,8 @@ -- | Waits for diagnostics to be published and returns them. waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do- diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics)- let (List diags) = diagsNot ^. params . LSP.diagnostics+ diagsNot <- skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)+ let diags = diagsNot ^. L.params . L.diagnostics return diags -- | The same as 'waitForDiagnostics', but will only match a specific@@ -500,34 +499,36 @@ else return res where matches :: Diagnostic -> Bool- matches d = d ^. source == Just (T.pack src)+ matches d = d ^. L.source == Just (T.pack src) -- | Expects a 'PublishDiagnosticsNotification' and throws an -- 'UnexpectedDiagnostics' exception if there are any diagnostics -- returned. noDiagnostics :: Session () noDiagnostics = do- diagsNot <- message STextDocumentPublishDiagnostics- when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics+ diagsNot <- message SMethod_TextDocumentPublishDiagnostics+ when (diagsNot ^. L.params . L.diagnostics /= []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document.-getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])+getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [SymbolInformation] [DocumentSymbol]) getDocumentSymbols doc = do- ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)+ TResponseMessage _ rspLid res <- request SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) case res of- Right (InL (List xs)) -> return (Left xs)- Right (InR (List xs)) -> return (Right xs)+ Right (InL xs) -> return (Left xs)+ Right (InR (InL xs)) -> return (Right xs)+ Right (InR (InR _)) -> return (Right []) Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getCodeActions doc range = do ctx <- getCodeActionContextInRange doc range- rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)+ rsp <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) - case rsp ^. result of- Right (List xs) -> return xs- Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)+ case rsp ^. L.result of+ Right (InL xs) -> return xs+ Right (InR _) -> return []+ Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) -- | Returns all the code actions in a document by -- querying the code actions at each of the current@@ -541,11 +542,12 @@ where go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] go ctx acc diag = do- ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)+ TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) case res of Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)- Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)+ Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)+ Right (InR _) -> pure acc getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext getCodeActionContextInRange doc caRange = do@@ -553,7 +555,7 @@ let diags = [ d | d@Diagnostic{_range=range} <- curDiags , overlappingRange caRange range ]- return $ CodeActionContext (List diags) Nothing+ return $ CodeActionContext diags Nothing Nothing where overlappingRange :: Range -> Range -> Bool overlappingRange (Range s e) range =@@ -570,12 +572,12 @@ getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext getCodeActionContext doc = do curDiags <- getCurrentDiagnostics doc- return $ CodeActionContext (List curDiags) Nothing+ return $ CodeActionContext curDiags Nothing Nothing -- | Returns the current diagnostics that have been sent to the client. -- Note that this does not wait for more to come in. getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]-getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get+getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get -- | Returns the tokens of all progress sessions that have started but not yet ended. getIncompleteProgressSessions :: Session (Set.Set ProgressToken)@@ -584,9 +586,9 @@ -- | Executes a command. executeCommand :: Command -> Session () executeCommand cmd = do- let args = decode $ encode $ fromJust $ cmd ^. arguments- execParams = ExecuteCommandParams Nothing (cmd ^. command) args- void $ sendRequest SWorkspaceExecuteCommand execParams+ let args = decode $ encode $ fromJust $ cmd ^. L.arguments+ execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args+ void $ sendRequest SMethod_WorkspaceExecuteCommand execParams -- | Executes a code action. -- Matching with the specification, if a code action@@ -594,21 +596,23 @@ -- be applied first. executeCodeAction :: CodeAction -> Session () executeCodeAction action = do- maybe (return ()) handleEdit $ action ^. edit- maybe (return ()) executeCommand $ action ^. command+ maybe (return ()) handleEdit $ action ^. L.edit+ maybe (return ()) executeCommand $ action ^. L.command where handleEdit :: WorkspaceEdit -> Session () handleEdit e = -- Its ok to pass in dummy parameters here as they aren't used- let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)- in updateState (FromServerMess SWorkspaceApplyEdit req)+ let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)+ in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do vfs <- vfs <$> get let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion- return (VersionedTextDocumentIdentifier uri ver)+ -- TODO: is this correct? Could return an OptionalVersionedTextDocumentIdentifier,+ -- but that complicated callers...+ return (VersionedTextDocumentIdentifier uri (fromMaybe 0 ver)) -- | Applys an edit to the document and returns the updated document version. applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier@@ -618,22 +622,18 @@ caps <- asks sessionCapabilities - let supportsDocChanges = fromMaybe False $ do- let mWorkspace = caps ^. LSP.workspace- C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ _ <- mWorkspace- C.WorkspaceEditClientCapabilities mDocChanges _ _ _ _ <- mEdit- mDocChanges+ let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just let wEdit = if supportsDocChanges then- let docEdit = TextDocumentEdit verDoc (List [InL edit])- in WorkspaceEdit Nothing (Just (List [InL docEdit])) Nothing+ let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]+ in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing else- let changes = HashMap.singleton (doc ^. uri) (List [edit])+ let changes = Map.singleton (doc ^. L.uri) [edit] in WorkspaceEdit (Just changes) Nothing Nothing - let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)- updateState (FromServerMess SWorkspaceApplyEdit req)+ let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)+ updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- version may have changed getVersionedDoc doc@@ -641,146 +641,139 @@ -- | Returns the completions for the position in the document. getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getCompletions doc pos = do- rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)+ rsp <- request SMethod_TextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) case getResponseResult rsp of- InL (List items) -> return items- InR (CompletionList _ (List items)) -> return items+ InL items -> return items+ InR (InL c) -> return $ c ^. L.items+ InR (InR _) -> return [] -- | Returns the references for the position in the document. getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. -> Position -- ^ The position to lookup. -> Bool -- ^ Whether to include declarations as references.- -> Session (List Location) -- ^ The locations of the references.+ -> Session [Location] -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos Nothing Nothing ctx- in getResponseResult <$> request STextDocumentReferences params+ in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params -- | Returns the declarations(s) for the term at the specified position. getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at.- -> Session ([Location] |? [LocationLink])-getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams+ -> Session (Declaration |? [DeclarationLink] |? Null)+getDeclarations doc pos = do+ rsp <- request SMethod_TextDocumentDeclaration (DeclarationParams doc pos Nothing Nothing)+ pure $ getResponseResult rsp -- | Returns the definition(s) for the term at the specified position. getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at.- -> Session ([Location] |? [LocationLink])-getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams+ -> Session (Definition |? [DefinitionLink] |? Null)+getDefinitions doc pos = do+ rsp <- request SMethod_TextDocumentDefinition (DefinitionParams doc pos Nothing Nothing)+ pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at.- -> Session ([Location] |? [LocationLink])-getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams+ -> Session (Definition |? [DefinitionLink] |? Null)+getTypeDefinitions doc pos = do+ rsp <- request SMethod_TextDocumentTypeDefinition (TypeDefinitionParams doc pos Nothing Nothing)+ pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. getImplementations :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at.- -> Session ([Location] |? [LocationLink])-getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams---getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink)))- => SClientMethod m- -> (TextDocumentIdentifier- -> Position- -> Maybe ProgressToken- -> Maybe ProgressToken- -> MessageParams m)- -> TextDocumentIdentifier- -> Position- -> Session ([Location] |? [LocationLink])-getDeclarationyRequest method paramCons doc pos = do- let params = paramCons doc pos Nothing Nothing- rsp <- request method params- case getResponseResult rsp of- InL loc -> pure (InL [loc])- InR (InL (List locs)) -> pure (InL locs)- InR (InR (List locLinks)) -> pure (InR locLinks)+ -> Session (Definition |? [DefinitionLink] |? Null)+getImplementations doc pos = do+ rsp <- request SMethod_TextDocumentImplementation (ImplementationParams doc pos Nothing Nothing)+ pure $ getResponseResult rsp -- | Renames the term at the specified position. rename :: TextDocumentIdentifier -> Position -> String -> Session () rename doc pos newName = do- let params = RenameParams doc pos Nothing (T.pack newName)- rsp <- request STextDocumentRename params+ let params = RenameParams Nothing doc pos (T.pack newName)+ rsp <- request SMethod_TextDocumentRename params let wEdit = getResponseResult rsp- req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)- updateState (FromServerMess SWorkspaceApplyEdit req)+ case nullToMaybe wEdit of+ Just e -> do+ let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)+ updateState (FromServerMess SMethod_WorkspaceApplyEdit req)+ Nothing -> pure () -- | Returns the hover information at the specified position. getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = let params = HoverParams doc pos Nothing- in getResponseResult <$> request STextDocumentHover params+ in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params -- | Returns the highlighted occurrences of the term at the specified position-getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight)+getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos = let params = DocumentHighlightParams doc pos Nothing Nothing- in getResponseResult <$> request STextDocumentDocumentHighlight params+ in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params -- | Checks the response for errors and throws an exception if needed. -- Returns the result if successful.-getResponseResult :: ResponseMessage m -> ResponseResult m+getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp =- case rsp ^. result of+ case rsp ^. L.result of Right x -> x- Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err+ Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () formatDoc doc opts = do let params = DocumentFormattingParams Nothing doc opts- edits <- getResponseResult <$> request STextDocumentFormatting params+ edits <- absorbNull . getResponseResult <$> request SMethod_TextDocumentFormatting params applyTextEdits doc edits -- | Applies formatting to the specified range in a document. formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () formatRange doc opts range = do let params = DocumentRangeFormattingParams Nothing doc range opts- edits <- getResponseResult <$> request STextDocumentRangeFormatting params+ edits <- absorbNull . getResponseResult <$> request SMethod_TextDocumentRangeFormatting params applyTextEdits doc edits -applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()+applyTextEdits :: TextDocumentIdentifier -> [TextEdit] -> Session () applyTextEdits doc edits =- let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing Nothing+ let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping- req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)- in updateState (FromServerMess SWorkspaceApplyEdit req)+ req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)+ in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do- rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)- case getResponseResult rsp of- List res -> pure res+ rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId)+ pure $ absorbNull $ getResponseResult rsp -- | Pass a param and return the response from `prepareCallHierarchy` prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem]-prepareCallHierarchy = resolveRequestWithListResp STextDocumentPrepareCallHierarchy+prepareCallHierarchy = resolveRequestWithListResp SMethod_TextDocumentPrepareCallHierarchy incomingCalls :: CallHierarchyIncomingCallsParams -> Session [CallHierarchyIncomingCall]-incomingCalls = resolveRequestWithListResp SCallHierarchyIncomingCalls+incomingCalls = resolveRequestWithListResp SMethod_CallHierarchyIncomingCalls outgoingCalls :: CallHierarchyOutgoingCallsParams -> Session [CallHierarchyOutgoingCall]-outgoingCalls = resolveRequestWithListResp SCallHierarchyOutgoingCalls+outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list.-resolveRequestWithListResp :: (ResponseResult m ~ Maybe (List a))- => SClientMethod m -> MessageParams m -> Session [a]+resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a+ . (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null))+ => SMethod m+ -> MessageParams m+ -> Session [a] resolveRequestWithListResp method params = do rsp <- request method params- case getResponseResult rsp of- Nothing -> pure []- Just (List x) -> pure x+ pure $ absorbNull $ getResponseResult rsp -- | Pass a param and return the response from `prepareCallHierarchy`-getSemanticTokens :: TextDocumentIdentifier -> Session (Maybe SemanticTokens)+getSemanticTokens :: TextDocumentIdentifier -> Session (SemanticTokens |? Null) getSemanticTokens doc = do let params = SemanticTokensParams Nothing Nothing doc- rsp <- request STextDocumentSemanticTokensFull params+ rsp <- request SMethod_TextDocumentSemanticTokensFull params pure $ getResponseResult rsp -- | Returns a list of capabilities that the server has requested to /dynamically/
src/Language/LSP/Test/Compat.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO {-# OPTIONS_GHC -Wunused-imports #-} module Language.LSP.Test.Compat where +import Data.Row import Data.Maybe+import qualified Data.Text as T import System.IO-import Language.LSP.Types #if MIN_VERSION_process(1,6,3) -- We have to hide cleanupProcess for process-1.6.3.0@@ -115,6 +120,5 @@ #endif --lspTestClientInfo :: ClientInfo-lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION)+lspTestClientInfo :: Rec ("name" .== T.Text .+ "version" .== Maybe T.Text)+lspTestClientInfo = #name .== "lsp-test" .+ #version .== (Just CURRENT_PACKAGE_VERSION)
src/Language/LSP/Test/Decoding.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeInType #-} module Language.LSP.Test.Decoding where @@ -17,8 +15,8 @@ import Data.Maybe import System.IO import System.IO.Error-import Language.LSP.Types-import Language.LSP.Types.Lens+import Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Test.Exceptions import Data.IxMap@@ -51,7 +49,7 @@ | isEOFError e = throw UnexpectedServerTermination | otherwise = throw e -type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )+type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type ) newRequestMap :: RequestMap newRequestMap = emptyIxMap@@ -66,10 +64,10 @@ helper acc msg = case msg of FromClientMess m mess -> case splitClientMethod m of IsClientNot -> acc- IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m+ IsClientReq -> fromJust $ updateRequestMap acc (mess ^. L.id) m IsClientEither -> case mess of NotMess _ -> acc- ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m+ ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. L.id) m _ -> acc decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
src/Language/LSP/Test/Exceptions.hs view
@@ -1,7 +1,7 @@ module Language.LSP.Test.Exceptions where import Control.Exception-import Language.LSP.Types+import Language.LSP.Protocol.Message import Data.Aeson import Data.Aeson.Encode.Pretty import Data.Algorithm.Diff@@ -16,7 +16,7 @@ | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String- | UnexpectedResponseError SomeLspId ResponseError+ | UnexpectedResponseError SomeLspId ResponseError | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage | MessageSendError Value IOError
src/Language/LSP/Test/Files.hs view
@@ -10,10 +10,11 @@ ) where -import Language.LSP.Types-import Language.LSP.Types.Lens hiding (id)+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Lens as L import Control.Lens-import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Maybe import System.Directory@@ -38,9 +39,11 @@ return newMsgs rootDir :: [Event] -> FilePath-rootDir (ClientEv _ (FromClientMess SInitialize req):_) =+rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) = fromMaybe (error "Couldn't find root dir") $ do- rootUri <- req ^. params .rootUri+ rootUri <- case req ^. L.params . L.rootUri of+ InL r -> Just r+ InR _ -> error "Couldn't find root dir" uriToFilePath rootUri rootDir _ = error "Couldn't find initialize request in session" @@ -52,54 +55,55 @@ where --TODO: Handle all other URIs that might need swapped- fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r- fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n- fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n+ fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n+ fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n fromClientMsg x = x fromServerMsg :: FromServerMessage -> FromServerMessage- fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r- fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n- fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =- let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation- swapUri' (InR si) = InR (swapUri location <$> si)- swapUri' (InL dss) = InL dss -- no file locations here- in FromServerRsp m $ r & result %~ (fmap swapUri')- fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)+ fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r+ fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n+ fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) =+ let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null+ swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here+ swapUri' (InR (InR n)) = InR $ InR n+ swapUri' (InL si) = InL (swapUri L.location <$> si)+ in FromServerRsp m $ r & L.result . _Right %~ swapUri'+ fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit fromServerMsg x = x swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit swapWorkspaceEdit e = let swapDocumentChangeUri :: DocumentChange -> DocumentChange- swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit+ swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile -- for RenameFile, we swap `newUri`- swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile+ swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile-- newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges- newChanges = fmap (swapKeys f) $ e ^. changes- in WorkspaceEdit newChanges newDocChanges Nothing+ in e & L.changes . _Just %~ swapKeys f+ & L.documentChanges . _Just . traversed%~ swapDocumentChangeUri - swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b- swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty+ swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b+ swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty - swapUri :: HasUri b Uri => Lens' a b -> a -> a+ swapUri :: L.HasUri b Uri => Lens' a b -> a -> a swapUri lens x =- let newUri = f (x ^. lens . uri)- in (lens . uri) .~ newUri $ x+ let newUri = f (x ^. lens . L.uri)+ in (lens . L.uri) .~ newUri $ x -- | Transforms rootUri/rootPath. transformInit :: InitializeParams -> InitializeParams transformInit x =- let newRootUri = fmap f (x ^. rootUri)- newRootPath = do- fp <- T.unpack <$> x ^. rootPath- let uri = filePathToUri fp- T.pack <$> uriToFilePath (f uri)- in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x+ let modifyRootPath p =+ let fp = T.unpack p+ uri = filePathToUri fp+ in case uriToFilePath (f uri) of+ Just fp -> T.pack fp+ Nothing -> p+ in x & L.rootUri . _L %~ f+ & L.rootPath . _Just . _L %~ modifyRootPath
src/Language/LSP/Test/Parsing.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}@@ -35,8 +31,10 @@ import qualified Data.Conduit.Parser (named) import qualified Data.Text as T import Data.Typeable-import Language.LSP.Types+import Language.LSP.Protocol.Message import Language.LSP.Test.Session+import GHC.TypeLits (KnownSymbol, symbolVal)+import Data.GADT.Compare -- $receiving -- To receive a message, specify the method of the message to expect:@@ -115,8 +113,8 @@ -- | Matches a request or a notification coming from the server. -- Doesn't match Custom Messages-message :: SServerMethod m -> Session (ServerMessage m)-message (SCustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead"+message :: SServerMethod m -> Session (TMessage m)+message (SMethod_CustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case FromServerMess m2 msg -> do res <- mEqServer m1 m2@@ -125,23 +123,31 @@ Left _f -> Nothing _ -> Nothing -customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))-customRequest m = named m $ satisfyMaybe $ \case- FromServerMess m1 msg -> case splitServerMethod m1 of- IsServerEither -> case msg of- ReqMess _ | m1 == SCustomMethod m -> Just msg+customRequest :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Request))+customRequest p =+ let m = T.pack $ symbolVal p+ in named m $ satisfyMaybe $ \case+ FromServerMess m1 msg -> case splitServerMethod m1 of+ IsServerEither -> case msg of+ ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of+ Just Refl -> Just msg+ _ -> Nothing+ _ -> Nothing _ -> Nothing _ -> Nothing- _ -> Nothing -customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))-customNotification m = named m $ satisfyMaybe $ \case- FromServerMess m1 msg -> case splitServerMethod m1 of- IsServerEither -> case msg of- NotMess _ | m1 == SCustomMethod m -> Just msg+customNotification :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Notification))+customNotification p =+ let m = T.pack $ symbolVal p+ in named m $ satisfyMaybe $ \case+ FromServerMess m1 msg -> case splitServerMethod m1 of+ IsServerEither -> case msg of+ NotMess _ -> case m1 `geq` SMethod_CustomMethod p of+ Just Refl -> Just msg+ _ -> Nothing+ _ -> Nothing _ -> Nothing _ -> Nothing- _ -> Nothing -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage@@ -169,7 +175,7 @@ FromServerRsp _ _ -> True -- | Matches a response coming from the server.-response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)+response :: SMethod (m :: Method ClientToServer Request) -> Session (TResponseMessage m) response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case FromServerRsp m2 msg -> do HRefl <- runEq mEqClient m1 m2@@ -177,12 +183,12 @@ _ -> Nothing -- | Like 'response', but matches a response for a specific id.-responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)+responseForId :: SMethod (m :: Method ClientToServer Request) -> LspId m -> Session (TResponseMessage m) responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do satisfyMaybe $ \msg -> do case msg of FromServerMess _ _ -> Nothing- FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do+ FromServerRsp m' rspMsg@(TResponseMessage _ lid' _) -> do HRefl <- runEq mEqClient m m' guard (Just lid == lid') pure rspMsg@@ -195,16 +201,16 @@ loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where- shouldSkip (FromServerMess SWindowLogMessage _) = True- shouldSkip (FromServerMess SWindowShowMessage _) = True- shouldSkip (FromServerMess SWindowShowMessageRequest _) = True- shouldSkip (FromServerMess SWindowShowDocument _) = True+ shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True+ shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True shouldSkip _ = False -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' -- (textDocument/publishDiagnostics) notification.-publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)+publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics) publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of- FromServerMess STextDocumentPublishDiagnostics diags -> Just diags+ FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just diags _ -> Nothing
src/Language/LSP/Test/Session.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-}@@ -43,16 +44,16 @@ import Control.Monad.Catch (MonadThrow) import Control.Monad.Except import Control.Monad.IO.Class+import Control.Monad.Trans.Class #if __GLASGOW_HASKELL__ == 806 import Control.Monad.Fail #endif-import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT, execState) import qualified Control.Monad.Trans.State as State import qualified Data.ByteString.Lazy.Char8 as B-import Data.Aeson hiding (Error)+import Data.Aeson hiding (Error, Null) import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser@@ -63,13 +64,11 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T-import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Function-import Language.LSP.Types.Capabilities-import Language.LSP.Types-import Language.LSP.Types.Lens-import qualified Language.LSP.Types.Lens as LSP+import Language.LSP.Protocol.Types as LSP+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message as LSP import Language.LSP.VFS import Language.LSP.Test.Compat import Language.LSP.Test.Decoding@@ -84,6 +83,7 @@ import System.Timeout ( timeout ) import Data.IORef import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))+import Data.Row -- | A session representing one instance of launching and connecting to a server. --@@ -142,7 +142,7 @@ -- Keep curTimeoutId in SessionContext, as its tied to messageChan , curTimeoutId :: IORef Int -- ^ The current timeout we are waiting on , requestMap :: MVar RequestMap- , initRsp :: MVar (ResponseMessage Initialize)+ , initRsp :: MVar (TResponseMessage Method_Initialize) , config :: SessionConfig , sessionCapabilities :: ClientCapabilities }@@ -231,9 +231,9 @@ yield msg chanSource - isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True- isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True- isLogNotification (ServerMessage (FromServerMess SWindowShowDocument _)) = True+ isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowMessage _)) = True+ isLogNotification (ServerMessage (FromServerMess SMethod_WindowLogMessage _)) = True+ isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowDocument _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()@@ -307,64 +307,67 @@ yield msg where respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()- respond (FromServerMess SWindowWorkDoneProgressCreate req) =- sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right Empty)- respond (FromServerMess SWorkspaceApplyEdit r) = do- sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing Nothing)+ respond (FromServerMess SMethod_WindowWorkDoneProgressCreate req) =+ sendMessage $ TResponseMessage "2.0" (Just $ req ^. L.id) (Right Null)+ respond (FromServerMess SMethod_WorkspaceApplyEdit r) = do+ sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right $ ApplyWorkspaceEditResult True Nothing Nothing) respond _ = pure () -- extract Uri out from DocumentChange -- didn't put this in `lsp-types` because TH was getting in the way documentChangeUri :: DocumentChange -> Uri-documentChangeUri (InL x) = x ^. textDocument . uri-documentChangeUri (InR (InL x)) = x ^. uri-documentChangeUri (InR (InR (InL x))) = x ^. oldUri-documentChangeUri (InR (InR (InR x))) = x ^. uri+documentChangeUri (InL x) = x ^. L.textDocument . L.uri+documentChangeUri (InR (InL x)) = x ^. L.uri+documentChangeUri (InR (InR (InL x))) = x ^. L.oldUri+documentChangeUri (InR (InR (InR x))) = x ^. L.uri updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()-updateState (FromServerMess SProgress req) = case req ^. params . value of- Begin _ ->- modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }- End _ ->- modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }+updateState (FromServerMess SMethod_Progress req) = case req ^. L.params . L.value of+ v | Just _ <- v ^? _workDoneProgressBegin ->+ modify $ \s -> s { curProgressSessions = Set.insert (req ^. L.params . L.token) $ curProgressSessions s }+ v | Just _ <- v ^? _workDoneProgressEnd ->+ modify $ \s -> s { curProgressSessions = Set.delete (req ^. L.params . L.token) $ curProgressSessions s } _ -> pure () -- Keep track of dynamic capability registration-updateState (FromServerMess SClientRegisterCapability req) = do- let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations+updateState (FromServerMess SMethod_ClientRegisterCapability req) = do+ let+ regs :: [SomeRegistration]+ regs = req ^.. L.params . L.registrations . traversed . to toSomeRegistration . _Just+ let newRegs = (\sr@(SomeRegistration r) -> (r ^. L.id, sr)) <$> regs modify $ \s -> s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } -updateState (FromServerMess SClientUnregisterCapability req) = do- let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations+updateState (FromServerMess SMethod_ClientUnregisterCapability req) = do+ let unRegs = (^. L.id) <$> req ^. L.params . L.unregisterations modify $ \s -> let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs in s { curDynCaps = newCurDynCaps } -updateState (FromServerMess STextDocumentPublishDiagnostics n) = do- let List diags = n ^. params . diagnostics- doc = n ^. params . uri+updateState (FromServerMess SMethod_TextDocumentPublishDiagnostics n) = do+ let diags = n ^. L.params . L.diagnostics+ doc = n ^. L.params . L.uri modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags } -updateState (FromServerMess SWorkspaceApplyEdit r) = do+updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do -- First, prefer the versioned documentChanges field- allChangeParams <- case r ^. params . edit . documentChanges of- Just (List cs) -> do+ allChangeParams <- case r ^. L.params . L.edit . L.documentChanges of+ Just (cs) -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs -- replace the user provided version numbers with the VFS ones + 1 -- (technically we should check that the user versions match the VFS ones)- cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs+ cs' <- traverseOf (traverse . _L . L.textDocument . _versionedTextDocumentIdentifier) bumpNewestVersion cs return $ mapMaybe getParamsFromDocumentChange cs' -- Then fall back to the changes field- Nothing -> case r ^. params . edit . changes of+ Nothing -> case r ^. L.params . L.edit . L.changes of Just cs -> do- mapM_ checkIfNeedsOpened (HashMap.keys cs)- concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs)+ mapM_ checkIfNeedsOpened (Map.keys cs)+ concat <$> mapM (uncurry getChangeParams) (Map.toList cs) Nothing -> error "WorkspaceEdit contains neither documentChanges nor changes!" @@ -372,20 +375,20 @@ let newVFS = flip execState (vfs s) $ changeFromServerVFS logger r return $ s { vfs = newVFS } - let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams+ let groupedParams = groupBy (\a b -> a ^. L.textDocument == b ^. L.textDocument) allChangeParams mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session- forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange)+ forM_ mergedParams (sendMessage . TNotificationMessage "2.0" SMethod_TextDocumentDidChange) -- Update VFS to new document versions- let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams- latestVersions = map ((^. textDocument) . last) sortedVersions+ let sortedVersions = map (sortBy (compare `on` (^. L.textDocument . L.version))) groupedParams+ latestVersions = map ((^. L.textDocument) . last) sortedVersions forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s- update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t+ update (VirtualFile _ file_ver t) = VirtualFile v (file_ver +1) t newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update in s { vfs = newVFS } @@ -399,23 +402,24 @@ let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents- msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)+ msg = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) sendMessage msg modifyM $ \s -> do let newVFS = flip execState (vfs s) $ openVFS logger msg return $ s { vfs = newVFS } - getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams- getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do- DidChangeTextDocumentParams docId (List $ map editToChangeEvent edits)+ getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams+ getParamsFromTextDocumentEdit (TextDocumentEdit docId edits) =+ DidChangeTextDocumentParams <$> docId ^? _versionedTextDocumentIdentifier <*> pure (map editToChangeEvent edits) + -- TODO: move somewhere reusable editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent- editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText)- editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText)+ editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText)+ editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText) getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams- getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit+ getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing bumpNewestVersion (VersionedTextDocumentIdentifier uri _) =@@ -426,18 +430,19 @@ textDocumentVersions uri = do vfs <- vfs <$> get let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version- pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]+ pure $ map (VersionedTextDocumentIdentifier uri) [curVer + 1..] textDocumentEdits uri edits = do vers <- textDocumentVersions uri- pure $ map (\(v, e) -> TextDocumentEdit v (List [InL e])) $ zip vers edits+ pure $ map (\(v, e) -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) $ zip vers edits - getChangeParams uri (List edits) = do- map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits)+ getChangeParams uri edits = do+ edits <- textDocumentEdits uri (reverse edits)+ pure $ catMaybes $ map getParamsFromTextDocumentEdit edits mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams- mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))- in DidChangeTextDocumentParams (head params ^. textDocument) (List events)+ mergeParams params = let events = concat (toList (map (toList . (^. L.contentChanges)) params))+ in DidChangeTextDocumentParams (head params ^. L.textDocument) events updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
test/DummyServer.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-} module DummyServer where import Control.Monad import Control.Monad.Reader-import Data.Aeson hiding (defaultOptions)-import qualified Data.HashMap.Strict as HM+import Data.Aeson hiding (defaultOptions, Null)+import qualified Data.Map.Strict as M import Data.List (isSuffixOf) import Data.String import UnliftIO.Concurrent@@ -15,8 +17,9 @@ import System.Directory import System.FilePath import System.Process-import Language.LSP.Types-import Data.Default+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message+import Data.Proxy withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do@@ -31,7 +34,7 @@ , staticHandlers = handlers , interpretHandler = \env -> Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO- , options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}+ , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]} } bracket@@ -41,53 +44,54 @@ data HandlerEnv = HandlerEnv- { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)- , absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)+ { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)+ , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) } handlers :: Handlers (ReaderT HandlerEnv (LspM ())) handlers = mconcat- [ notificationHandler SInitialized $+ [ notificationHandler SMethod_Initialized $ \_noti ->- sendNotification SWindowLogMessage $- LogMessageParams MtLog "initialized"- , requestHandler STextDocumentHover $+ sendNotification SMethod_WindowLogMessage $+ LogMessageParams MessageType_Log "initialized"+ , requestHandler SMethod_TextDocumentHover $ \_req responder -> responder $ Right $- Just $- Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing- , requestHandler STextDocumentDocumentSymbol $+ InL $+ Hover (InL (MarkupContent MarkupKind_PlainText "hello")) Nothing+ , requestHandler SMethod_TextDocumentDocumentSymbol $ \_req responder -> responder $ Right $- InL $- List- [ DocumentSymbol- "foo"- Nothing- SkObject- Nothing- Nothing- (mkRange 0 0 3 6)- (mkRange 0 0 3 6)- Nothing- ]- , notificationHandler STextDocumentDidOpen $+ InR $ InL+ [ DocumentSymbol+ "foo"+ Nothing+ SymbolKind_Object+ Nothing+ Nothing+ (mkRange 0 0 3 6)+ (mkRange 0 0 3 6)+ Nothing+ ]+ , notificationHandler SMethod_TextDocumentDidOpen $ \noti -> do- let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti+ let TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc Just fp = uriToFilePath uri diag = Diagnostic (mkRange 0 0 0 1)- (Just DsWarning)+ (Just DiagnosticSeverity_Warning) (Just (InL 42))+ Nothing (Just "dummy-server") "Here's a warning" Nothing Nothing+ Nothing withRunInIO $ \runInIO -> do when (".hs" `isSuffixOf` fp) $@@ -96,39 +100,37 @@ do threadDelay (2 * 10 ^ 6) runInIO $- sendNotification STextDocumentPublishDiagnostics $- PublishDiagnosticsParams uri Nothing (List [diag])+ sendNotification SMethod_TextDocumentPublishDiagnostics $+ PublishDiagnosticsParams uri Nothing [diag] -- also act as a registerer for workspace/didChangeWatchedFiles when (".register" `isSuffixOf` fp) $ do let regOpts =- DidChangeWatchedFilesRegistrationOptions $- List- [ FileSystemWatcher- "*.watch"- (Just (WatchKind True True True))- ]+ DidChangeWatchedFilesRegistrationOptions+ [ FileSystemWatcher+ (GlobPattern $ InL $ Pattern "*.watch")+ (Just WatchKind_Create)+ ] Just token <- runInIO $- registerCapability SWorkspaceDidChangeWatchedFiles regOpts $+ registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti ->- sendNotification SWindowLogMessage $- LogMessageParams MtLog "got workspace/didChangeWatchedFiles"+ sendNotification SMethod_WindowLogMessage $+ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" runInIO $ asks relRegToken >>= \v -> putMVar v token when (".register.abs" `isSuffixOf` fp) $ do curDir <- getCurrentDirectory let regOpts =- DidChangeWatchedFilesRegistrationOptions $- List- [ FileSystemWatcher- (fromString $ curDir </> "*.watch")- (Just (WatchKind True True True))- ]+ DidChangeWatchedFilesRegistrationOptions+ [ FileSystemWatcher+ (GlobPattern $ InL $ Pattern $ fromString $ curDir </> "*.watch")+ (Just WatchKind_Create)+ ] Just token <- runInIO $- registerCapability SWorkspaceDidChangeWatchedFiles regOpts $+ registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti ->- sendNotification SWindowLogMessage $- LogMessageParams MtLog "got workspace/didChangeWatchedFiles"+ sendNotification SMethod_WindowLogMessage $+ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" runInIO $ asks absRegToken >>= \v -> putMVar v token -- also act as an unregisterer for workspace/didChangeWatchedFiles when (".unregister" `isSuffixOf` fp) $@@ -142,57 +144,57 @@ -- this handler is used by the -- "text document VFS / sends back didChange notifications (documentChanges)" test- , notificationHandler STextDocumentDidChange $ \noti -> do- let NotificationMessage _ _ params = noti- void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params)+ , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do+ let TNotificationMessage _ _ params = noti+ void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params) - , requestHandler SWorkspaceExecuteCommand $ \req resp -> do+ , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do case req of- RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) -> do+ TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do let Success docUri = fromJSON val- edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]+ edit = [TextEdit (mkRange 0 0 0 5) "howdy"] params = ApplyWorkspaceEditParams (Just "Howdy edit") $- WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing Nothing- resp $ Right Null- void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))- RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [val]))) -> do+ WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing+ resp $ Right $ InR $ Null+ void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))+ TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do let Success versionedDocUri = fromJSON val- edit = List [InL (TextEdit (mkRange 0 0 0 5) "howdy")]+ edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")] documentEdit = TextDocumentEdit versionedDocUri edit params = ApplyWorkspaceEditParams (Just "Howdy edit") $- WorkspaceEdit Nothing (Just (List [InL documentEdit])) Nothing- resp $ Right Null- void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))- RequestMessage _ _ _ (ExecuteCommandParams _ name _) ->+ WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing+ resp $ Right $ InR Null+ void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))+ TRequestMessage _ _ _ (ExecuteCommandParams _ name _) -> error $ "unsupported command: " <> show name- , requestHandler STextDocumentCodeAction $ \req resp -> do- let RequestMessage _ _ _ params = req+ , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do+ let TRequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params- CodeActionContext diags _ = cactx+ CodeActionContext diags _ _ = cactx codeActions = fmap diag2ca diags diag2ca d = CodeAction "Delete this" Nothing- (Just (List [d]))+ (Just [d]) Nothing Nothing Nothing (Just (Command "" "deleteThis" Nothing)) Nothing- resp $ Right $ InR <$> codeActions- , requestHandler STextDocumentCompletion $ \_req resp -> do- let res = CompletionList True (List [item])+ resp $ Right $ InL $ InR <$> codeActions+ , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do+ let res = CompletionList True Nothing [item] item = CompletionItem "foo"- (Just CiConstant)- (Just (List [])) Nothing+ (Just CompletionItemKind_Constant)+ (Just []) Nothing Nothing Nothing@@ -206,15 +208,17 @@ Nothing Nothing Nothing- resp $ Right $ InR res- , requestHandler STextDocumentPrepareCallHierarchy $ \req resp -> do- let RequestMessage _ _ _ params = req+ Nothing+ Nothing+ resp $ Right $ InR $ InL res+ , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do+ let TRequestMessage _ _ _ params = req CallHierarchyPrepareParams _ pos _ = params Position x y = pos item = CallHierarchyItem "foo"- SkMethod+ SymbolKind_Method Nothing Nothing (Uri "")@@ -222,21 +226,21 @@ (Range (Position 2 3) (Position 4 5)) Nothing if x == 0 && y == 0- then resp $ Right Nothing- else resp $ Right $ Just $ List [item]- , requestHandler SCallHierarchyIncomingCalls $ \req resp -> do- let RequestMessage _ _ _ params = req+ then resp $ Right $ InR Null+ else resp $ Right $ InL [item]+ , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do+ let TRequestMessage _ _ _ params = req CallHierarchyIncomingCallsParams _ _ item = params- resp $ Right $ Just $- List [CallHierarchyIncomingCall item (List [Range (Position 2 3) (Position 4 5)])]- , requestHandler SCallHierarchyOutgoingCalls $ \req resp -> do- let RequestMessage _ _ _ params = req+ resp $ Right $ InL+ [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]]+ , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do+ let TRequestMessage _ _ _ params = req CallHierarchyOutgoingCallsParams _ _ item = params- resp $ Right $ Just $- List [CallHierarchyOutgoingCall item (List [Range (Position 4 5) (Position 2 3)])]- , requestHandler STextDocumentSemanticTokensFull $ \_req resp -> do- let tokens = makeSemanticTokens def [SemanticTokenAbsolute 0 1 2 SttType []]+ resp $ Right $ InL+ [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]]+ , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do+ let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []] case tokens of- Left t -> resp $ Left $ ResponseError InternalError t Nothing- Right tokens -> resp $ Right $ Just tokens+ Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing+ Right tokens -> resp $ Right $ InL tokens ]
test/Test.hs view
@@ -3,29 +3,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TypeApplications #-} import DummyServer import Test.Hspec import Data.Aeson import Data.Default-import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M import Data.Either import Data.Maybe import qualified Data.Text as T import Data.Type.Equality+import Data.Proxy import Control.Applicative.Combinators import Control.Concurrent import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List, Iso) import Language.LSP.Test-import Language.LSP.Types-import Language.LSP.Types.Lens hiding- (capabilities, message, rename, applyEdit)-import qualified Language.LSP.Types.Lens as LSP-import Language.LSP.Types.Capabilities as LSP+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Lens as L import System.Directory import System.FilePath import System.Timeout@@ -44,10 +42,10 @@ in session `shouldThrow` anySessionException it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- initializeResponse- liftIO $ rsp ^. result `shouldSatisfy` isRight+ liftIO $ rsp ^. L.result `shouldSatisfy` isRight it "runSessionWithConfig" $ \(hin, hout) ->- runSessionWithHandles hin hout def didChangeCaps "." $ return ()+ runSessionWithHandles hin hout def fullCaps "." $ return () describe "withTimeout" $ do it "times out" $ \(hin, hout) ->@@ -56,7 +54,7 @@ -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout- withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException@@ -96,7 +94,7 @@ withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc -- should now timeout- skipManyTill anyMessage (message SWorkspaceApplyEdit)+ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False in sesh `shouldThrow` isTimeout@@ -106,7 +104,7 @@ it "throw on time out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do skipMany loggingNotification- _ <- message SWorkspaceApplyEdit+ _ <- message SMethod_WorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException @@ -119,17 +117,17 @@ describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ \(hin, hout) ->- let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True+ let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) ->- let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True+ let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False sesh = do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)+ sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification- response STextDocumentRename -- the wrong type+ response SMethod_TextDocumentRename -- the wrong type in runSessionWithHandles hin hout def fullCaps "." sesh `shouldThrow` selector @@ -139,20 +137,20 @@ doc <- openDoc "test/data/refactor/Main.hs" "haskell" VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc - let args = toJSON (VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion)- reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [args]))+ let args = toJSON (VersionedTextDocumentIdentifier (doc ^. L.uri) beforeVersion)+ reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just [args]) - request_ SWorkspaceExecuteCommand reqParams+ request_ SMethod_WorkspaceExecuteCommand reqParams - editReq <- message SWorkspaceApplyEdit+ editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do- let Just (List [InL(TextDocumentEdit vdoc (List [InL edit_]))]) =- editReq ^. params . edit . documentChanges- vdoc `shouldBe` VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion+ let Just [InL(TextDocumentEdit vdoc [InL edit_])] =+ editReq ^. L.params . L.edit . L.documentChanges+ vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" - change <- customNotification "custom/textDocument/didChange"- let NotMess (NotificationMessage _ _ (c::Value)) = change+ change <- customNotification (Proxy @"custom/textDocument/didChange")+ let NotMess (TNotificationMessage _ _ (c::Value)) = change Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc @@ -168,15 +166,15 @@ runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" - let args = toJSON (doc ^. uri)- reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))- request_ SWorkspaceExecuteCommand reqParams+ let args = toJSON (doc ^. L.uri)+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just [args])+ request_ SMethod_WorkspaceExecuteCommand reqParams - editReq <- message SWorkspaceApplyEdit+ editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do- let (Just cs) = editReq ^. params . edit . changes- [(u, List es)] = HM.toList cs- u `shouldBe` doc ^. uri+ let (Just cs) = editReq ^. L.params . L.edit . L.changes+ [(u, es)] = M.toList cs+ u `shouldBe` doc ^. L.uri es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"] contents <- documentContents doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"@@ -186,9 +184,9 @@ runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" - let args = toJSON (doc ^. uri)- reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))- request_ SWorkspaceExecuteCommand reqParams+ let args = toJSON (doc ^. L.uri)+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just [args])+ request_ SMethod_WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -198,7 +196,7 @@ waitForDiagnostics [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2)) actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18))- liftIO $ action ^. title `shouldBe` "Delete this"+ liftIO $ action ^. L.title `shouldBe` "Delete this" liftIO $ actions `shouldSatisfy` null describe "getAllCodeActions" $@@ -208,8 +206,8 @@ actions <- getAllCodeActions doc liftIO $ do let [InR action] = actions- action ^. title `shouldBe` "Delete this"- action ^. command . _Just . command `shouldBe` "deleteThis"+ action ^. L.title `shouldBe` "Delete this"+ action ^. L.command . _Just . L.command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do@@ -217,19 +215,19 @@ skipMany loggingNotification - Left (mainSymbol:_) <- getDocumentSymbols doc+ Right (mainSymbol:_) <- getDocumentSymbols doc liftIO $ do- mainSymbol ^. name `shouldBe` "foo"- mainSymbol ^. kind `shouldBe` SkObject- mainSymbol ^. range `shouldBe` mkRange 0 0 3 6+ mainSymbol ^. L.name `shouldBe` "foo"+ mainSymbol ^. L.kind `shouldBe` SymbolKind_Object+ mainSymbol ^. L.range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do- it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def docChangesCaps "." $ do+ it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc+ VersionedTextDocumentIdentifier _ oldVersion <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"- VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit+ VersionedTextDocumentIdentifier _ newVersion <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1 it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"@@ -244,7 +242,7 @@ comps <- getCompletions doc (Position 5 5) let item = head comps- liftIO $ item ^. label `shouldBe` "foo"+ liftIO $ item ^. L.label `shouldBe` "foo" -- describe "getReferences" $ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do@@ -277,8 +275,8 @@ openDoc "test/data/Error.hs" "haskell" [diag] <- waitForDiagnosticsSource "dummy-server" liftIO $ do- diag ^. severity `shouldBe` Just DsWarning- diag ^. source `shouldBe` Just "dummy-server"+ diag ^. L.severity `shouldBe` Just DiagnosticSeverity_Warning+ diag ^. L.source `shouldBe` Just "dummy-server" -- describe "rename" $ do -- it "works" $ \(hin, hout) -> pendingWith "HaRe not in hie-bios yet"@@ -328,24 +326,24 @@ describe "satisfy" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do openDoc "test/data/Format.hs" "haskell"- let pred (FromServerMess SWindowLogMessage _) = True+ let pred (FromServerMess SMethod_WindowLogMessage _) = True pred _ = False void $ satisfy pred describe "satisfyMaybe" $ do it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do -- Wait for window/logMessage "initialized" from the server.- let pred (FromServerMess SWindowLogMessage _) = Just "match" :: Maybe String+ let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String pred _ = Nothing :: Maybe String result <- satisfyMaybe pred liftIO $ result `shouldBe` "match" it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do- let pred (FromServerMess STextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String+ let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but -- not a textDocument/publishDiagnostics.- result <- satisfyMaybe pred <|> (message SWindowLogMessage *> pure "no match")+ result <- satisfyMaybe pred <|> (message SMethod_WindowLogMessage *> pure "no match") liftIO $ result `shouldBe` "no match" describe "ignoreLogNotifications" $@@ -360,26 +358,26 @@ loggingNotification -- initialized log message createDoc ".register" "haskell" ""- message SClientRegisterCapability+ message SMethod_ClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" ""- msg <- message SWindowLogMessage- liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"+ msg <- message SMethod_WindowLogMessage+ liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" - [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities+ [SomeRegistration (TRegistration _ regMethod regOpts)] <- getRegisteredCapabilities liftIO $ do- case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of+ case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of Just (Right HRefl) ->- regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List- [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])+ regOpts `shouldBe` (Just $ DidChangeWatchedFilesRegistrationOptions+ [ FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create) ]) _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" ""- message SClientUnregisterCapability+ message SMethod_ClientUnregisterCapability createDoc "Bar.watch" "haskell" ""- void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing+ void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -389,18 +387,18 @@ loggingNotification -- initialized log message createDoc ".register.abs" "haskell" ""- message SClientRegisterCapability+ message SMethod_ClientRegisterCapability doc <- createDoc (curDir </> "Foo.watch") "haskell" ""- msg <- message SWindowLogMessage- liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"+ msg <- message SMethod_WindowLogMessage+ liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister.abs" "haskell" ""- message SClientUnregisterCapability+ message SMethod_ClientUnregisterCapability createDoc (curDir </> "Bar.watch") "haskell" ""- void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing+ void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -408,37 +406,25 @@ let workPos = Position 1 0 notWorkPos = Position 0 0 params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing- item = CallHierarchyItem "foo" SkFunction Nothing Nothing (Uri "")+ item = CallHierarchyItem "foo" SymbolKind_Function Nothing Nothing (Uri "") (Range (Position 1 2) (Position 3 4)) (Range (Position 1 2) (Position 3 4)) Nothing it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- prepareCallHierarchy (params workPos)- liftIO $ head rsp ^. range `shouldBe` Range (Position 2 3) (Position 4 5)+ liftIO $ head rsp ^. L.range `shouldBe` Range (Position 2 3) (Position 4 5) it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- prepareCallHierarchy (params notWorkPos) liftIO $ rsp `shouldBe` [] it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do- [CallHierarchyIncomingCall _ (List fromRanges)] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item)+ [CallHierarchyIncomingCall _ fromRanges] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 2 3) (Position 4 5) it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do- [CallHierarchyOutgoingCall _ (List fromRanges)] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item)+ [CallHierarchyOutgoingCall _ fromRanges] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3) describe "semantic tokens" $ do it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do let doc = TextDocumentIdentifier (Uri "")- Just toks <- getSemanticTokens doc- liftIO $ toks ^. xdata `shouldBe` List [0,1,2,1,0]--didChangeCaps :: ClientCapabilities-didChangeCaps = def { _workspace = Just workspaceCaps }- where- workspaceCaps = def { _didChangeConfiguration = Just configCaps }- configCaps = DidChangeConfigurationClientCapabilities (Just True)--docChangesCaps :: ClientCapabilities-docChangesCaps = def { _workspace = Just workspaceCaps }- where- workspaceCaps = def { _workspaceEdit = Just editCaps }- editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing Nothing Nothing+ InL toks <- getSemanticTokens doc+ liftIO $ toks ^. L.data_ `shouldBe` [0,1,2,1,0]