X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=c14eb44fd140a5f94b5307e72b03fa90dc6b77a2;hb=6f3106ce987b2a3794ee7ab444c8bcc204a7b3d2;hp=81bdc8a8b465087baa960fbc6b1303e8497fcff7;hpb=a7fd35b1582f9816d8caa90a7b2e3aa765fb0446;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 81bdc8a..c14eb44 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -1,5 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} @@ -91,7 +97,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 @@ -105,7 +111,6 @@ import Language.Haskell.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 @@ -158,7 +163,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do runSessionWithHandles 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... @@ -170,10 +175,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 +192,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 (Nothing :: Maybe Value) >> sendNotification SExit (Just Empty) -- | Listens to the server output until the shutdown ack, -- makes sure it matches the record and signals any semaphores @@ -201,17 +206,17 @@ runSessionWithConfig config' serverExe caps rootDir session = do 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,7 +241,7 @@ 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)) @@ -261,86 +266,70 @@ getDocumentEdit doc = do -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse -- @ -- Note: will skip any messages in between the request and the response. -request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) +request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId -- | 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 (ResponseParams m) => ResponseMessage m -> Session () sendResponse = sendMessage -- | Returns the initialize response that was received from the server. @@ -367,7 +356,7 @@ createDoc file languageId contents = do rootDir <- asks rootDir caps <- asks sessionCapabilities absFile <- liftIO $ canonicalizePath (rootDir file) - let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $ + let regs = filter (\r -> r ^. method == SomeClientMethod SWorkspaceDidChangeWatchedFiles) $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool watchHits (FileSystemWatcher pattern kind) = @@ -382,7 +371,7 @@ createDoc file languageId contents = do createHits (WatchKind create _ _) = create - regHits :: Registration -> Bool + regHits :: SomeRegistration -> Bool regHits reg = isJust $ do opts <- reg ^. registerOptions fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of @@ -398,7 +387,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 +408,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,7 +434,7 @@ 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 @@ -467,44 +456,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 doc Nothing) :: Session DocumentSymbolsResponse case res of - Right (DSDocumentSymbols (List xs)) -> return (Left xs) - Right (DSSymbolInformation (List xs)) -> return (Right xs) - Left err -> throw (UnexpectedResponseError rspLid err) + Right (L (List xs)) -> return (Left xs) + Right (R (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 doc range ctx Nothing) 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 doc (diag ^. range) ctx Nothing) 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 @@ -522,7 +511,7 @@ executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams (cmd ^. command) args Nothing - request_ WorkspaceExecuteCommand execParams + request_ SWorkspaceExecuteCommand execParams -- | Executes a code action. -- Matching with the specification, if a code action @@ -536,8 +525,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 e) + in updateState (FromServerMess SWorkspaceApplyEdit req) -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier @@ -558,7 +547,7 @@ 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 mDocChanges @@ -571,8 +560,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 wEdit) + updateState (FromServerMess SWorkspaceApplyEdit req) -- version may have changed getVersionedDoc doc @@ -580,21 +569,21 @@ 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) case getResponseResult rsp of - Completions (List items) -> return items - CompletionList (CompletionListType _ (List items)) -> return items + L (List items) -> return items + R (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 + in getResponseResult <$> request STextDocumentReferences params -- | Returns the definition(s) for the term at the specified position. getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. @@ -602,72 +591,76 @@ getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Session [Location] -- ^ The location(s) of the definitions getDefinitions doc pos = do let params = TextDocumentPositionParams doc pos Nothing - rsp <- request TextDocumentDefinition params :: Session DefinitionResponse + rsp <- request STextDocumentDefinition params :: Session DefinitionResponse case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs + L loc -> pure [loc] + R locs -> pure locs -- | 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 + -> Session (Location |? List Location |? List LocationLink) -- ^ The location(s) of the definitions getTypeDefinitions doc pos = let params = TextDocumentPositionParams doc pos Nothing - in getResponseResult <$> request TextDocumentTypeDefinition params + rsp <- request STextDocumentTypeDefinition params :: Session TypeDefinitionResponse + case getResponseResult rsp of + L loc -> pure [loc] + R locs -> pure locs -- | 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 + rsp <- request STextDocumentRename params :: Session RenameResponse let wEdit = getResponseResult rsp - req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - updateState (ReqApplyWorkspaceEdit req) + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams 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 + 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 + 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 -> ResponseParams 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 + 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 + 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 - req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - in updateState (ReqApplyWorkspaceEdit req) + -- Send a dummy message to updateState so it can do bookkeeping + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams 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 tId Nothing) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res @@ -675,5 +668,5 @@ getCodeLenses tId = do -- register during the 'Session'. -- -- @since 0.11.0.0 -getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get