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
build-depends: base >= 4.10 && < 5
, haskell-lsp >= 0.22 && < 0.24
, aeson
+ , time
, aeson-pretty
, ansi-terminal
, async
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
(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
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...
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!
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
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
-- 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))
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.
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) =
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
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
-- | 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
-- 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
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
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
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
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
-- | 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
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.
-> 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
-> 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
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
{-# 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
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
| 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 _
| 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
+ -}
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
| ReplayOutOfOrder FromServerMessage [FromServerMessage]
| UnexpectedDiagnostics
| IncorrectApplyEditRequest String
- | UnexpectedResponseError LspIdRsp ResponseError
+ | UnexpectedResponseError SomeLspId ResponseError
| UnexpectedServerTermination
| IllegalInitSequenceMessage FromServerMessage
deriving Eq
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
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
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
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
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
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
( -- $receiving
satisfy
, satisfyMaybe
- , message
, anyRequest
, anyResponse
, anyNotification
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
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'
publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
publishDiagnosticsNotification = named "Publish diagnostics notification" $
satisfyMaybe $ \msg -> case msg of
- NotPublishDiagnostics diags -> Just diags
+ FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
_ -> Nothing
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
{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
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
data SessionState = SessionState
{
- curReqId :: LspId
+ curReqId :: Int
, vfs :: VFS
, curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
, overridingTimeout :: Bool
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)) ()
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 ()
(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)) ()
=> 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
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
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
projects / lsp-test.git / commitdiff