From: Zubin Duggal Date: Thu, 4 Jun 2020 13:51:26 +0000 (+0530) Subject: Initial attempt at updating for singleton-methods X-Git-Tag: 0.13.0.0~7^2~21 X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=98d03792f46f3ac870c010a78944822569e76763 Initial attempt at updating for singleton-methods --- diff --git a/cabal.project b/cabal.project index 543e44f..48970de 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,10 @@ packages: . flags: +DummyServer test-show-details: direct haddock-quickjump: True + +source-repository-package + type: git + location: https://github.com/alanz/haskell-lsp.git + tag: 9dc38a36be7f1b316eff5dcf223a96d02c3ac6fd + subdir: . + haskell-lsp-types diff --git a/lsp-test.cabal b/lsp-test.cabal index 5016ba2..2b89d3d 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -44,6 +44,7 @@ library build-depends: base >= 4.10 && < 5 , haskell-lsp >= 0.22 && < 0.24 , aeson + , time , aeson-pretty , ansi-terminal , async diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index dbfc801..6fefc03 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -1,5 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} @@ -105,7 +110,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 +162,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 +174,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 +191,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 ExitParams) -- | Listens to the server output until the shutdown ack, -- makes sure it matches the record and signals any semaphores @@ -201,17 +205,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 +240,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)) @@ -255,92 +259,82 @@ getDocumentEdit doc = do let mMap = req ^. params . edit . changes in maybe False (HashMap.member (doc ^. uri)) mMap +message :: SServerMethod m -> Session (ServerMessage m) +message = undefined -- TODO + -- | 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 -- @ -- 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 - - sendMessage req - - return id + \r -> return $ fromJust $ updateRequestMap r id method - where nextId (IdInt i) = IdInt (i + 1) - nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 + let mkSession :: Session () -> Session () + mkSession x = x --- | 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] + mkSession $ case splitClientMethod method of + IsClientReq -> sendMessage mess + IsClientEither -> sendMessage $ ReqMess mess + return id -- | 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 +361,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) = @@ -398,7 +392,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 +413,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 +439,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,27 +461,27 @@ 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) + Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult] 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 @@ -501,10 +495,10 @@ getAllCodeActions doc = do where go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] 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 +516,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 +530,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 @@ -571,8 +565,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,7 +574,7 @@ 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 @@ -590,11 +584,11 @@ getCompletions doc pos = do 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,7 +596,7 @@ 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 @@ -613,7 +607,7 @@ getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Session [Location] -- ^ The location(s) of the definitions getTypeDefinitions doc pos = do let params = TextDocumentPositionParams doc pos Nothing - rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse + rsp <- request STextDocumentTypeDefinition params :: Session TypeDefinitionResponse case getResponseResult rsp of SingleLoc loc -> pure [loc] MultiLoc locs -> pure locs @@ -622,56 +616,56 @@ getTypeDefinitions doc pos = do 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 -- 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 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 diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index 350b525..9051821 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -1,8 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Language.Haskell.LSP.Test.Decoding where import Prelude hiding ( id ) import Data.Aeson +import Data.Aeson.Types import Data.Foldable import Control.Exception import Control.Lens @@ -12,10 +18,13 @@ import System.IO import System.IO.Error import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test.Exceptions import qualified Data.HashMap.Strict as HM +import Data.IxMap +import Data.Kind +import Data.Maybe + getAllMessages :: Handle -> IO [B.ByteString] getAllMessages h = do done <- hIsEOF h @@ -53,93 +62,29 @@ getHeaders h = do | isEOFError e = throw UnexpectedServerTermination | otherwise = throw e -type RequestMap = HM.HashMap LspId ClientMethod +type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type ) newRequestMap :: RequestMap -newRequestMap = HM.empty +newRequestMap = emptyIxMap -updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap -updateRequestMap reqMap id method = HM.insert id method reqMap +updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap +updateRequestMap reqMap id method = insertIxMap id method reqMap getRequestMap :: [FromClientMessage] -> RequestMap -getRequestMap = foldl helper HM.empty +getRequestMap = foldl' helper emptyIxMap where + helper :: RequestMap -> FromClientMessage -> RequestMap helper acc msg = case msg of - (ReqInitialize val) -> insert val acc - (ReqShutdown val) -> insert val acc - (ReqHover val) -> insert val acc - (ReqCompletion val) -> insert val acc - (ReqCompletionItemResolve val) -> insert val acc - (ReqSignatureHelp val) -> insert val acc - (ReqDefinition val) -> insert val acc - (ReqTypeDefinition val) -> insert val acc - (ReqFindReferences val) -> insert val acc - (ReqDocumentHighlights val) -> insert val acc - (ReqDocumentSymbols val) -> insert val acc - (ReqWorkspaceSymbols val) -> insert val acc - (ReqCodeAction val) -> insert val acc - (ReqCodeLens val) -> insert val acc - (ReqCodeLensResolve val) -> insert val acc - (ReqDocumentFormatting val) -> insert val acc - (ReqDocumentRangeFormatting val) -> insert val acc - (ReqDocumentOnTypeFormatting val) -> insert val acc - (ReqRename val) -> insert val acc - (ReqExecuteCommand val) -> insert val acc - (ReqDocumentLink val) -> insert val acc - (ReqDocumentLinkResolve val) -> insert val acc - (ReqWillSaveWaitUntil val) -> insert val acc + FromClientMess m mess -> case splitClientMethod m of + IsClientNot -> acc + IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m _ -> acc - insert m = HM.insert (m ^. id) (m ^. method) - -matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage -matchResponseMsgType req = case req of - Initialize -> RspInitialize . decoded - Shutdown -> RspShutdown . decoded - TextDocumentHover -> RspHover . decoded - TextDocumentCompletion -> RspCompletion . decoded - CompletionItemResolve -> RspCompletionItemResolve . decoded - TextDocumentSignatureHelp -> RspSignatureHelp . decoded - TextDocumentDefinition -> RspDefinition . decoded - TextDocumentTypeDefinition -> RspTypeDefinition . decoded - TextDocumentReferences -> RspFindReferences . decoded - TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded - TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded - WorkspaceSymbol -> RspWorkspaceSymbols . decoded - TextDocumentCodeAction -> RspCodeAction . decoded - TextDocumentCodeLens -> RspCodeLens . decoded - CodeLensResolve -> RspCodeLensResolve . decoded - TextDocumentFormatting -> RspDocumentFormatting . decoded - TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded - TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded - TextDocumentRename -> RspRename . decoded - WorkspaceExecuteCommand -> RspExecuteCommand . decoded - TextDocumentDocumentLink -> RspDocumentLink . decoded - DocumentLinkResolve -> RspDocumentLinkResolve . decoded - TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded - CustomClientMethod{} -> RspCustomServer . decoded - x -> error . ((show x ++ " is not a request: ") ++) . show - where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: " - ++ show req ++ "\n" ++ show x) - (decode x) decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage -decodeFromServerMsg reqMap bytes = - case HM.lookup "method" obj of - Just methodStr -> case fromJSON methodStr of - Success method -> case method of - -- We can work out the type of the message - TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes - WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes - WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes - CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes - Progress -> - fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes] - WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes - TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes - WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes - ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes - ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes - WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes +decodeFromServerMsg reqMap bytes = fst $ fromJust $ parseMaybe p obj + where obj = fromJust $ decode bytes :: Value + p = parseServerMessage (\i -> (,()) <$> lookupIxMap i reqMap) + {- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" CustomServerMethod _ @@ -148,10 +93,4 @@ decodeFromServerMsg reqMap bytes = | otherwise -> NotCustomServer $ fromJust $ decode bytes Error e -> error e - - Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of - Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of - Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type - Nothing -> error "Couldn't match up response with request" - Nothing -> error "Couldn't decode message" - where obj = fromJust $ decode bytes :: Object + -} diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index afb48df..c1fec6f 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -1,7 +1,6 @@ module Language.Haskell.LSP.Test.Exceptions where import Control.Exception -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Data.Aeson import Data.Aeson.Encode.Pretty @@ -17,7 +16,7 @@ data SessionException = Timeout (Maybe FromServerMessage) | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String - | UnexpectedResponseError LspIdRsp ResponseError + | UnexpectedResponseError SomeLspId ResponseError | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage deriving Eq diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index b56f536..a9e6af6 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Files @@ -7,16 +8,19 @@ module Language.Haskell.LSP.Test.Files ) where -import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens -import Language.Haskell.LSP.Messages import Control.Lens import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Maybe import System.Directory import System.FilePath +import Data.Time.Clock + +data Event + = ClientEv UTCTime FromClientMessage + | ServerEv UTCTime FromServerMessage swapFiles :: FilePath -> [Event] -> IO [Event] swapFiles relCurBaseDir msgs = do @@ -32,7 +36,7 @@ swapFiles relCurBaseDir msgs = do return newMsgs rootDir :: [Event] -> FilePath -rootDir (FromClient _ (ReqInitialize req):_) = +rootDir (ClientEv _ (FromClientMess SInitialize req):_) = fromMaybe (error "Couldn't find root dir") $ do rootUri <- req ^. params .rootUri uriToFilePath rootUri @@ -41,34 +45,29 @@ rootDir _ = error "Couldn't find initialize request in session" mapUris :: (Uri -> Uri) -> Event -> Event mapUris f event = case event of - FromClient t msg -> FromClient t (fromClientMsg msg) - FromServer t msg -> FromServer t (fromServerMsg msg) + ClientEv t msg -> ClientEv t (fromClientMsg msg) + ServerEv t msg -> ServerEv t (fromServerMsg msg) where --TODO: Handle all other URIs that might need swapped - fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n - fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r - fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r - fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r + 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 x = x fromServerMsg :: FromServerMessage -> FromServerMessage - fromServerMsg (ReqApplyWorkspaceEdit r) = - ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r - - fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n - - fromServerMsg (RspDocumentSymbols r) = + 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' (DSSymbolInformation si) = DSSymbolInformation (swapUri location <$> si) swapUri' (DSDocumentSymbols dss) = DSDocumentSymbols dss -- no file locations here - in RspDocumentSymbols $ r & result %~ (fmap swapUri') - - fromServerMsg (RspRename r) = RspRename $ r & result %~ (fmap swapWorkspaceEdit) - + in FromServerRsp m $ r & result %~ (fmap swapUri') + fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit) fromServerMsg x = x swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs index f8b1822..c225f13 100644 --- a/src/Language/Haskell/LSP/Test/Messages.hs +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -2,153 +2,4 @@ module Language.Haskell.LSP.Test.Messages where import Data.Aeson -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types - -isServerResponse :: FromServerMessage -> Bool -isServerResponse (RspInitialize _) = True -isServerResponse (RspShutdown _) = True -isServerResponse (RspHover _) = True -isServerResponse (RspCompletion _) = True -isServerResponse (RspCompletionItemResolve _) = True -isServerResponse (RspSignatureHelp _) = True -isServerResponse (RspDefinition _) = True -isServerResponse (RspTypeDefinition _) = True -isServerResponse (RspFindReferences _) = True -isServerResponse (RspDocumentHighlights _) = True -isServerResponse (RspDocumentSymbols _) = True -isServerResponse (RspWorkspaceSymbols _) = True -isServerResponse (RspCodeAction _) = True -isServerResponse (RspCodeLens _) = True -isServerResponse (RspCodeLensResolve _) = True -isServerResponse (RspDocumentFormatting _) = True -isServerResponse (RspDocumentRangeFormatting _) = True -isServerResponse (RspDocumentOnTypeFormatting _) = True -isServerResponse (RspRename _) = True -isServerResponse (RspExecuteCommand _) = True -isServerResponse (RspError _) = True -isServerResponse (RspDocumentLink _) = True -isServerResponse (RspDocumentLinkResolve _) = True -isServerResponse (RspWillSaveWaitUntil _) = True -isServerResponse _ = False - -isServerRequest :: FromServerMessage -> Bool -isServerRequest (ReqRegisterCapability _) = True -isServerRequest (ReqApplyWorkspaceEdit _) = True -isServerRequest (ReqShowMessage _) = True -isServerRequest (ReqUnregisterCapability _) = True -isServerRequest _ = False - -isServerNotification :: FromServerMessage -> Bool -isServerNotification (NotPublishDiagnostics _) = True -isServerNotification (NotLogMessage _) = True -isServerNotification (NotShowMessage _) = True -isServerNotification (NotTelemetry _) = True -isServerNotification (NotCancelRequestFromServer _) = True -isServerNotification _ = False - -handleServerMessage - :: forall a. - (forall b c. RequestMessage ServerMethod b c -> a) - -> (forall d. ResponseMessage d -> a) - -> (forall e. NotificationMessage ServerMethod e -> a) - -> FromServerMessage - -> a -handleServerMessage request response notification msg = case msg of - (ReqRegisterCapability m) -> request m - (ReqApplyWorkspaceEdit m) -> request m - (ReqShowMessage m) -> request m - (ReqUnregisterCapability m) -> request m - (ReqCustomServer m) -> request m - (ReqWorkDoneProgressCreate m) -> request m - (RspInitialize m) -> response m - (RspShutdown m) -> response m - (RspHover m) -> response m - (RspCompletion m) -> response m - (RspCompletionItemResolve m) -> response m - (RspSignatureHelp m) -> response m - (RspDefinition m) -> response m - (RspFindReferences m) -> response m - (RspDocumentHighlights m) -> response m - (RspDocumentSymbols m) -> response m - (RspWorkspaceSymbols m) -> response m - (RspCodeAction m) -> response m - (RspCodeLens m) -> response m - (RspCodeLensResolve m) -> response m - (RspDocumentFormatting m) -> response m - (RspDocumentRangeFormatting m) -> response m - (RspDocumentOnTypeFormatting m) -> response m - (RspRename m) -> response m - (RspExecuteCommand m) -> response m - (RspError m) -> response m - (RspDocumentLink m) -> response m - (RspDocumentLinkResolve m) -> response m - (RspWillSaveWaitUntil m) -> response m - (RspTypeDefinition m) -> response m - (RspImplementation m) -> response m - (RspDocumentColor m) -> response m - (RspColorPresentation m) -> response m - (RspFoldingRange m) -> response m - (RspCustomServer m) -> response m - (NotPublishDiagnostics m) -> notification m - (NotLogMessage m) -> notification m - (NotShowMessage m) -> notification m - (NotWorkDoneProgressBegin m) -> notification m - (NotWorkDoneProgressReport m) -> notification m - (NotWorkDoneProgressEnd m) -> notification m - (NotTelemetry m) -> notification m - (NotCancelRequestFromServer m) -> notification m - (NotCustomServer m) -> notification m - -handleClientMessage - :: forall a. - (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a) - -> (forall d . ToJSON d => ResponseMessage d -> a) - -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a) - -> FromClientMessage - -> a -handleClientMessage request response notification msg = case msg of - (ReqInitialize m) -> request m - (ReqShutdown m) -> request m - (ReqHover m) -> request m - (ReqCompletion m) -> request m - (ReqCompletionItemResolve m) -> request m - (ReqSignatureHelp m) -> request m - (ReqDefinition m) -> request m - (ReqFindReferences m) -> request m - (ReqDocumentHighlights m) -> request m - (ReqDocumentSymbols m) -> request m - (ReqWorkspaceSymbols m) -> request m - (ReqCodeAction m) -> request m - (ReqCodeLens m) -> request m - (ReqCodeLensResolve m) -> request m - (ReqDocumentFormatting m) -> request m - (ReqDocumentRangeFormatting m) -> request m - (ReqDocumentOnTypeFormatting m) -> request m - (ReqPrepareRename m) -> request m - (ReqRename m) -> request m - (ReqExecuteCommand m) -> request m - (ReqDocumentLink m) -> request m - (ReqDocumentLinkResolve m) -> request m - (ReqWillSaveWaitUntil m) -> request m - (ReqImplementation m) -> request m - (ReqTypeDefinition m) -> request m - (ReqDocumentColor m) -> request m - (ReqColorPresentation m) -> request m - (ReqFoldingRange m) -> request m - (RspApplyWorkspaceEdit m) -> response m - (RspFromClient m) -> response m - (NotInitialized m) -> notification m - (NotExit m) -> notification m - (NotCancelRequestFromClient m) -> notification m - (NotDidChangeConfiguration m) -> notification m - (NotDidOpenTextDocument m) -> notification m - (NotDidChangeTextDocument m) -> notification m - (NotDidCloseTextDocument m) -> notification m - (NotWillSaveTextDocument m) -> notification m - (NotDidSaveTextDocument m) -> notification m - (NotDidChangeWatchedFiles m) -> notification m - (NotDidChangeWorkspaceFolders m) -> notification m - (NotWorkDoneProgressCancel m) -> notification m - (ReqCustomClient m) -> request m - (NotCustomClient m) -> notification m diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 12ef1a6..d1fec45 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,5 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,7 +11,6 @@ module Language.Haskell.LSP.Test.Parsing ( -- $receiving satisfy , satisfyMaybe - , message , anyRequest , anyResponse , anyNotification @@ -28,7 +31,6 @@ import Data.Conduit.Parser hiding (named) import qualified Data.Conduit.Parser (named) import qualified Data.Text as T import Data.Typeable -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Test.Messages @@ -98,50 +100,56 @@ satisfyMaybe pred = do named :: T.Text -> Session a -> Session a named s (Session x) = Session (Data.Conduit.Parser.named s x) +{- -- | Matches a message of type @a@. message :: forall a. (Typeable a, FromJSON a) => Session a message = let parser = decode . encodeMsg :: FromServerMessage -> Maybe a in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ satisfyMaybe parser +-} -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage -anyNotification = named "Any notification" $ satisfy isServerNotification +anyNotification = named "Any notification" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerNot -> True + _ -> False + FromServerRsp _ _ -> False -- | Matches if the message is a request. anyRequest :: Session FromServerMessage -anyRequest = named "Any request" $ satisfy isServerRequest +anyRequest = named "Any request" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerReq -> True + _ -> False + FromServerRsp _ _ -> False -- | Matches if the message is a response. anyResponse :: Session FromServerMessage -anyResponse = named "Any response" $ satisfy isServerResponse +anyResponse = named "Any response" $ satisfy $ \case + FromServerMess _ _ -> False + FromServerRsp _ _ -> True -- | Matches a response for a specific id. -responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) +responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m) responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) satisfyMaybe $ \msg -> do - z <- parser msg - guard (z ^. LSP.id == responseId lid) - pure z + case msg of + FromServerMess _ _ -> Nothing + FromServerRsp m rsp -> undefined -- TODO -- | Matches any type of message. anyMessage :: Session FromServerMessage anyMessage = satisfy (const True) --- | A version of encode that encodes FromServerMessages as if they --- weren't wrapped. -encodeMsg :: FromServerMessage -> B.ByteString -encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) - -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where - shouldSkip (NotLogMessage _) = True - shouldSkip (NotShowMessage _) = True - shouldSkip (ReqShowMessage _) = True + shouldSkip (FromServerMess SWindowLogMessage _) = True + shouldSkip (FromServerMess SWindowShowMessage _) = True + shouldSkip (FromServerMess SWindowShowMessageRequest _) = True shouldSkip _ = False -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' @@ -149,5 +157,5 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip publishDiagnosticsNotification :: Session PublishDiagnosticsNotification publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of - NotPublishDiagnostics diags -> Just diags + FromServerMess STextDocumentPublishDiagnostics diags -> Just diags _ -> Nothing diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 45de159..2e3c514 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -10,8 +10,6 @@ import Control.Concurrent import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Text as T -import Language.Haskell.LSP.Capture -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens as LSP import Data.Aeson diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9e4aa81..d43d11a 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} @@ -59,7 +60,6 @@ import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Function -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens @@ -160,7 +160,7 @@ bumpTimeoutId prev = do data SessionState = SessionState { - curReqId :: LspId + curReqId :: Int , vfs :: VFS , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] , overridingTimeout :: Bool @@ -219,8 +219,8 @@ runSession context state (Session session) = runReaderT (runStateT conduit state yield msg chanSource - isLogNotification (ServerMessage (NotShowMessage _)) = True - isLogNotification (ServerMessage (NotLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -260,7 +260,7 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty + initState vfs = SessionState 0 vfs mempty False Nothing mempty runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () @@ -282,7 +282,7 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer - (const $ runSession' session) + (const $ initVFS $ \vfs -> runSession context (initState vfs) session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -294,25 +294,25 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () -- Keep track of dynamic capability registration -updateState (ReqRegisterCapability req) = do +updateState (FromServerMess SClientRegisterCapability req) = do let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations modify $ \s -> s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } -updateState (ReqUnregisterCapability req) = do +updateState (FromServerMess SClientUnregisterCapability req) = do let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations modify $ \s -> let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs in s { curDynCaps = newCurDynCaps } -updateState (NotPublishDiagnostics n) = do +updateState (FromServerMess STextDocumentPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags } -updateState (ReqApplyWorkspaceEdit r) = do +updateState (FromServerMess SWorkspaceApplyEdit r) = do -- First, prefer the versioned documentChanges field allChangeParams <- case r ^. params . edit . documentChanges of @@ -335,7 +335,7 @@ updateState (ReqApplyWorkspaceEdit r) = do mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange) -- Update VFS to new document versions let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams @@ -358,7 +358,7 @@ updateState (ReqApplyWorkspaceEdit r) = do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents - msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) modifyM $ \s -> do