X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FLSP%2FTest.hs;fp=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=3eda63e90dd6fb39a936a431f68bac7042147da0;hb=f89cfd8c1b3fe2b9e0805b564216ab3a5eda1b82;hp=dbfc8012973e0165ce97a9c508b440f380b1371e;hpb=4d107b7623ae621525f2efe19ee20cfc40c086c4;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/LSP/Test.hs similarity index 57% rename from src/Language/Haskell/LSP/Test.hs rename to src/Language/LSP/Test.hs index dbfc801..3eda63e 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -1,10 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-| -Module : Language.Haskell.LSP.Test +Module : Language.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com Stability : experimental @@ -12,20 +17,21 @@ Portability : non-portable Provides the framework to start functionally testing . -You should import "Language.Haskell.LSP.Types" alongside this. +You should import "Language.LSP.Types" alongside this. -} -module Language.Haskell.LSP.Test +module Language.LSP.Test ( -- * Sessions Session , runSession - -- ** Config , runSessionWithConfig + , runSessionWithHandles + -- ** Config , SessionConfig(..) , defaultConfig , C.fullCaps -- ** Exceptions - , module Language.Haskell.LSP.Test.Exceptions + , module Language.LSP.Test.Exceptions , withTimeout -- * Sending , request @@ -34,7 +40,7 @@ module Language.Haskell.LSP.Test , sendNotification , sendResponse -- * Receving - , module Language.Haskell.LSP.Test.Parsing + , module Language.LSP.Test.Parsing -- * Utilities -- | Quick helper functions for common tasks. @@ -67,8 +73,10 @@ module Language.Haskell.LSP.Test -- ** References , getReferences -- ** Definitions + , getDeclarations , getDefinitions , getTypeDefinitions + , getImplementations -- ** Renaming , rename -- ** Hover @@ -91,7 +99,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Control.Exception -import Control.Lens hiding ((.=), List) +import Control.Lens hiding ((.=), List, Empty) import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.IO as T @@ -100,23 +108,23 @@ import Data.Default import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Maybe -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename) -import qualified Language.Haskell.LSP.Types.Lens as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as C -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Test.Compat -import Language.Haskell.LSP.Test.Decoding -import Language.Haskell.LSP.Test.Exceptions -import Language.Haskell.LSP.Test.Parsing -import Language.Haskell.LSP.Test.Session -import Language.Haskell.LSP.Test.Server +import qualified Language.LSP.Types.Lens as LSP +import qualified Language.LSP.Types.Capabilities as C +import Language.LSP.VFS +import Language.LSP.Test.Compat +import Language.LSP.Test.Decoding +import Language.LSP.Test.Exceptions +import Language.LSP.Test.Parsing +import Language.LSP.Test.Session +import Language.LSP.Test.Server import System.Environment import System.IO import System.Directory import System.FilePath +import System.Process (ProcessHandle) import qualified System.FilePath.Glob as Glob -- | Starts a new session. @@ -126,7 +134,7 @@ import qualified System.FilePath.Glob as Glob -- > diags <- waitForDiagnostics -- > let pos = Position 12 5 -- > params = TextDocumentPositionParams doc --- > hover <- request TextDocumentHover params +-- > hover <- request STextdocumentHover params runSession :: String -- ^ The command to run the server. -> C.ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. @@ -142,27 +150,60 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> Session a -- ^ The session to run. -> IO a runSessionWithConfig config' serverExe caps rootDir session = do + config <- envOverrideConfig config' + withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> + runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session + +-- | Starts a new session, using the specified handles to communicate with the +-- server. You can use this to host the server within the same process. +-- An example with lsp might look like: +-- +-- > (hinRead, hinWrite) <- createPipe +-- > (houtRead, houtWrite) <- createPipe +-- > +-- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition +-- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do +-- > -- ... +runSessionWithHandles :: Handle -- ^ The input handle + -> Handle -- ^ The output handle + -> SessionConfig + -> C.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 +runSessionWithHandles = runSessionWithHandles' Nothing + + +runSessionWithHandles' :: Maybe ProcessHandle + -> Handle -- ^ The input handle + -> Handle -- ^ The output handle + -> SessionConfig + -> C.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 +runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir config <- envOverrideConfig config' - let initializeParams = InitializeParams (Just pid) + let initializeParams = InitializeParams Nothing + (Just pid) + (Just lspTestClientInfo) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) Nothing caps (Just TraceOff) - Nothing - withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> - runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do + (List <$> initialWorkspaceFolders config) + runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls - -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse - initReqId <- sendRequest Initialize initializeParams + initReqId <- sendRequest SInitialize initializeParams -- Because messages can be sent in between the request and response, -- collect them and then... - (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId) + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId) case initRspMsg ^. LSP.result of Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) @@ -170,10 +211,10 @@ runSessionWithConfig config' serverExe caps rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams + sendNotification SInitialized (Just InitializedParams) case lspConfig config of - Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) + Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) Nothing -> return () -- ... relay them back to the user Session so they can match on them! @@ -187,7 +228,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do where -- | Asks the server to shutdown and exit politely exitServer :: Session () - exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams + exitServer = request_ SShutdown Empty >> sendNotification SExit Empty -- | Listens to the server output until the shutdown ack, -- makes sure it matches the record and signals any semaphores @@ -195,23 +236,22 @@ runSessionWithConfig config' serverExe caps rootDir session = do listenServer serverOut context = do msgBytes <- getNextMessage serverOut - reqMap <- readMVar $ requestMap context - - let msg = decodeFromServerMsg reqMap msgBytes + msg <- modifyMVar (requestMap context) $ \reqMap -> + pure $ decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) case msg of - (RspShutdown _) -> return () + (FromServerRsp SShutdown _) -> 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 (NotShowMessage _) = pure () - checkLegalBetweenMessage (NotLogMessage _) = pure () - checkLegalBetweenMessage (NotTelemetry _) = pure () - checkLegalBetweenMessage (ReqShowMessage _) = pure () + checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure () + checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure () + checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure () + checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure () checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg) -- | Check environment variables to override the config @@ -236,21 +276,19 @@ documentContents doc = do -- and returns the new content getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do - req <- message :: Session ApplyWorkspaceEditRequest + req <- message SWorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $ liftIO $ throw (IncorrectApplyEditRequest (show req)) documentContents doc where - checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool checkDocumentChanges req = let changes = req ^. params . edit . documentChanges maybeDocs = fmap (fmap (^. textDocument . uri)) changes in case maybeDocs of Just docs -> (doc ^. uri) `elem` docs Nothing -> False - checkChanges :: ApplyWorkspaceEditRequest -> Bool checkChanges req = let mMap = req ^. params . edit . changes in maybe False (HashMap.member (doc ^. uri)) mMap @@ -258,95 +296,79 @@ getDocumentEdit doc = do -- | Sends a request to the server and waits for its response. -- Will skip any messages in between the request and the response -- @ --- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse +-- rsp <- request STextDocumentDocumentSymbol params -- @ -- Note: will skip any messages in between the request and the response. -request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) -request m = sendRequest m >=> skipManyTill anyMessage . responseForId +request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m) +request m = sendRequest m >=> skipManyTill anyMessage . responseForId m -- | The same as 'sendRequest', but discard the response. -request_ :: ToJSON params => ClientMethod -> params -> Session () -request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value)) +request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session () +request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. sendRequest - :: ToJSON params - => ClientMethod -- ^ The request method. - -> params -- ^ The request parameters. - -> Session LspId -- ^ The id of the request that was sent. + :: SClientMethod m -- ^ The request method. + -> MessageParams m -- ^ The request parameters. + -> Session (LspId m) -- ^ The id of the request that was sent. sendRequest method params = do - id <- curReqId <$> get - modify $ \c -> c { curReqId = nextId id } + idn <- curReqId <$> get + modify $ \c -> c { curReqId = idn+1 } + let id = IdInt idn - let req = RequestMessage' "2.0" id method params + let mess = RequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask liftIO $ modifyMVar_ reqMap $ - \r -> return $ updateRequestMap r id method + \r -> return $ fromJust $ updateRequestMap r id method - sendMessage req + ~() <- case splitClientMethod method of + IsClientReq -> sendMessage mess + IsClientEither -> sendMessage $ ReqMess mess return id - where nextId (IdInt i) = IdInt (i + 1) - nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 - --- | A custom type for request message that doesn't --- need a response type, allows us to infer the request --- message type without using proxies. -data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a - -instance ToJSON a => ToJSON (RequestMessage' a) where - toJSON (RequestMessage' rpc id method params) = - object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] - - -- | Sends a notification to the server. -sendNotification :: ToJSON a - => ClientMethod -- ^ The notification method. - -> a -- ^ The notification parameters. +sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method. + -> MessageParams m -- ^ The notification parameters. -> Session () - -- Open a virtual file if we send a did open text document notification -sendNotification TextDocumentDidOpen params = do - let params' = fromJust $ decode $ encode params - n :: DidOpenTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidOpen params' +sendNotification STextDocumentDidOpen params = do + let n = NotificationMessage "2.0" STextDocumentDidOpen params oldVFS <- vfs <$> get let (newVFS,_) = openVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n -- Close a virtual file if we send a close text document notification -sendNotification TextDocumentDidClose params = do - let params' = fromJust $ decode $ encode params - n :: DidCloseTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidClose params' +sendNotification STextDocumentDidClose params = do + let n = NotificationMessage "2.0" STextDocumentDidClose params oldVFS <- vfs <$> get let (newVFS,_) = closeVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n -sendNotification TextDocumentDidChange params = do - let params' = fromJust $ decode $ encode params - n :: DidChangeTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidChange params' +sendNotification STextDocumentDidChange params = do + let n = NotificationMessage "2.0" STextDocumentDidChange params oldVFS <- vfs <$> get let (newVFS,_) = changeFromClientVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n -sendNotification method params = sendMessage (NotificationMessage "2.0" method params) +sendNotification method params = + case splitClientMethod method of + IsClientNot -> sendMessage (NotificationMessage "2.0" method params) + IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params) -- | Sends a response to the server. -sendResponse :: ToJSON a => ResponseMessage a -> Session () +sendResponse :: ToJSON (ResponseResult m) => ResponseMessage 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 InitializeResponse +initializeResponse :: Session (ResponseMessage Initialize) initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) -- | /Creates/ a new text document. This is different from 'openDoc' @@ -367,8 +389,10 @@ createDoc file languageId contents = do rootDir <- asks rootDir caps <- asks sessionCapabilities absFile <- liftIO $ canonicalizePath (rootDir file) - let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $ - Map.elems dynCaps + let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles] + pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] + pred _ = mempty + regs = concatMap pred $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool watchHits (FileSystemWatcher pattern kind) = -- If WatchKind is exlcuded, defaults to all true as per spec @@ -382,15 +406,8 @@ createDoc file languageId contents = do createHits (WatchKind create _ _) = create - regHits :: Registration -> Bool - regHits reg = isJust $ do - opts <- reg ^. registerOptions - fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of - Success x -> Just x - Error _ -> Nothing - if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers) - then Just () - else Nothing + regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers) clientCapsSupports = caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just @@ -398,7 +415,7 @@ createDoc file languageId contents = do shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs when shouldSend $ - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri (rootDir file)) FcCreated ] openDoc' file languageId contents @@ -419,21 +436,21 @@ openDoc' file languageId contents = do let fp = rootDir context file uri = filePathToUri fp item = TextDocumentItem uri (T.pack languageId) 0 contents - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) + sendNotification STextDocumentDidOpen (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 TextDocumentDidClose params + sendNotification STextDocumentDidClose 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 TextDocumentDidChange params + sendNotification STextDocumentDidChange params -- | Gets the Uri for the file corrected to the session directory. getDocUri :: FilePath -> Session Uri @@ -445,12 +462,12 @@ getDocUri file = do -- | Waits for diagnostics to be published and returns them. waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do - diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification + diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics) let (List diags) = diagsNot ^. params . LSP.diagnostics return diags -- | The same as 'waitForDiagnostics', but will only match a specific --- 'Language.Haskell.LSP.Types._source'. +-- 'Language.LSP.Types._source'. waitForDiagnosticsSource :: String -> Session [Diagnostic] waitForDiagnosticsSource src = do diags <- waitForDiagnostics @@ -467,44 +484,44 @@ waitForDiagnosticsSource src = do -- returned. noDiagnostics :: Session () noDiagnostics = do - diagsNot <- message :: Session PublishDiagnosticsNotification + diagsNot <- message STextDocumentPublishDiagnostics when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) getDocumentSymbols doc = do - ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse + ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) case res of - Right (DSDocumentSymbols (List xs)) -> return (Left xs) - Right (DSSymbolInformation (List xs)) -> return (Right xs) - Left err -> throw (UnexpectedResponseError rspLid err) + Right (InL (List xs)) -> return (Left xs) + Right (InR (List xs)) -> return (Right xs) + Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) -- | Returns the code actions in the specified range. -getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult] +getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getCodeActions doc range = do ctx <- getCodeActionContext doc - rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing) + rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) case rsp ^. result of Right (List xs) -> return xs - Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error) + Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error) -- | Returns all the code actions in a document by -- querying the code actions at each of the current -- diagnostics' positions. -getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult] +getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] getAllCodeActions doc = do ctx <- getCodeActionContext doc foldM (go ctx) [] =<< getCurrentDiagnostics doc where - go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] + go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] go ctx acc diag = do - ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) + ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx) case res of - Left e -> throw (UnexpectedResponseError rspLid e) + Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs) getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext @@ -521,8 +538,8 @@ getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args Nothing - request_ WorkspaceExecuteCommand execParams + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + void $ sendRequest SWorkspaceExecuteCommand execParams -- | Executes a code action. -- Matching with the specification, if a code action @@ -536,8 +553,8 @@ executeCodeAction action = do where handleEdit :: WorkspaceEdit -> Session () handleEdit e = -- Its ok to pass in dummy parameters here as they aren't used - let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) - in updateState (ReqApplyWorkspaceEdit req) + let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) + in updateState (FromServerMess SWorkspaceApplyEdit req) -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier @@ -558,9 +575,9 @@ applyEdit doc edit = do caps <- asks sessionCapabilities let supportsDocChanges = fromMaybe False $ do - let mWorkspace = C._workspace caps + let mWorkspace = caps ^. LSP.workspace C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace - C.WorkspaceEditClientCapabilities mDocChanges <- mEdit + C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit mDocChanges let wEdit = if supportsDocChanges @@ -571,8 +588,8 @@ applyEdit doc edit = do let changes = HashMap.singleton (doc ^. uri) (List [edit]) in WorkspaceEdit (Just changes) Nothing - let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - updateState (ReqApplyWorkspaceEdit req) + let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + updateState (FromServerMess SWorkspaceApplyEdit req) -- version may have changed getVersionedDoc doc @@ -580,98 +597,119 @@ applyEdit doc edit = do -- | Returns the completions for the position in the document. getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getCompletions doc pos = do - rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing) + rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) case getResponseResult rsp of - Completions (List items) -> return items - CompletionList (CompletionListType _ (List items)) -> return items + InL (List items) -> return items + InR (CompletionList _ (List items)) -> return items -- | 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 [Location] -- ^ The locations of the references. + -> Session (List Location) -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl - params = ReferenceParams doc pos ctx Nothing - in getResponseResult <$> request TextDocumentReferences params + params = ReferenceParams doc pos Nothing Nothing ctx + in getResponseResult <$> request STextDocumentReferences 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 -- | 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] -- ^ The location(s) of the definitions -getDefinitions doc pos = do - let params = TextDocumentPositionParams doc pos Nothing - rsp <- request TextDocumentDefinition params :: Session DefinitionResponse - case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs + -> Session ([Location] |? [LocationLink]) +getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams -- | 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] -- ^ The location(s) of the definitions -getTypeDefinitions doc pos = do - let params = TextDocumentPositionParams doc pos Nothing - rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse + -> Session ([Location] |? [LocationLink]) +getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams + +-- | 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 - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs + InL loc -> pure (InL [loc]) + InR (InL (List locs)) -> pure (InL locs) + InR (InR (List locLinks)) -> pure (InR locLinks) -- | Renames the term at the specified position. rename :: TextDocumentIdentifier -> Position -> String -> Session () rename doc pos newName = do - let params = RenameParams doc pos (T.pack newName) Nothing - rsp <- request TextDocumentRename params :: Session RenameResponse + let params = RenameParams doc pos Nothing (T.pack newName) + rsp <- request STextDocumentRename params let wEdit = getResponseResult rsp - req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - updateState (ReqApplyWorkspaceEdit req) + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + updateState (FromServerMess SWorkspaceApplyEdit req) -- | Returns the hover information at the specified position. getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = - let params = TextDocumentPositionParams doc pos Nothing - in getResponseResult <$> request TextDocumentHover params + let params = HoverParams doc pos Nothing + in getResponseResult <$> request STextDocumentHover params -- | Returns the highlighted occurences of the term at the specified position -getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] +getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight) getHighlights doc pos = - let params = TextDocumentPositionParams doc pos Nothing - in getResponseResult <$> request TextDocumentDocumentHighlight params + let params = DocumentHighlightParams doc pos Nothing Nothing + in getResponseResult <$> request STextDocumentDocumentHighlight params -- | Checks the response for errors and throws an exception if needed. -- Returns the result if successful. -getResponseResult :: ResponseMessage a -> a +getResponseResult :: ResponseMessage m -> ResponseResult m getResponseResult rsp = case rsp ^. result of Right x -> x - Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err + Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () formatDoc doc opts = do - let params = DocumentFormattingParams doc opts Nothing - edits <- getResponseResult <$> request TextDocumentFormatting params + let params = DocumentFormattingParams Nothing doc opts + edits <- getResponseResult <$> request STextDocumentFormatting 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 doc range opts Nothing - edits <- getResponseResult <$> request TextDocumentRangeFormatting params + let params = DocumentRangeFormattingParams Nothing doc range opts + edits <- getResponseResult <$> request STextDocumentRangeFormatting params applyTextEdits doc edits applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () applyTextEdits doc edits = let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing -- Send a dummy message to updateState so it can do bookkeeping - req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - in updateState (ReqApplyWorkspaceEdit req) + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + in updateState (FromServerMess SWorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do - rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse + rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId) case getResponseResult rsp of List res -> pure res @@ -679,5 +717,5 @@ getCodeLenses tId = do -- register during the 'Session'. -- -- @since 0.11.0.0 -getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get