From f2862c89be8f545d0cda5890dce58d31c15127f6 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 1 Sep 2020 16:23:23 +0100 Subject: [PATCH] Implement responseForId --- src/Language/Haskell/LSP/Test.hs | 9 ++--- src/Language/Haskell/LSP/Test/Decoding.hs | 8 ++-- src/Language/Haskell/LSP/Test/Parsing.hs | 48 +++++++++++++++-------- 3 files changed, 39 insertions(+), 26 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 80ea0e3..9866be9 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -196,7 +196,7 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio -- Because messages can be sent in between the request and response, -- collect them and then... - (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId) + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId) case initRspMsg ^. LSP.result of Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) @@ -229,10 +229,9 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio listenServer serverOut context = do msgBytes <- getNextMessage serverOut - msg <- modifyMVar (requestMap context) $ \reqMap -> do - let (msg, newReqMap) = decodeFromServerMsg reqMap msgBytes + msg <- modifyMVar (requestMap context) $ \reqMap -> + pure $ decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) - pure (newReqMap, msg) case msg of (FromServerRsp SShutdown _) -> return () @@ -296,7 +295,7 @@ getDocumentEdit doc = do -- @ -- Note: will skip any messages in between the request and the response. request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m) -request m = sendRequest m >=> skipManyTill anyMessage . responseForId +request m = sendRequest m >=> skipManyTill anyMessage . responseForId m -- | The same as 'sendRequest', but discard the response. request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session () diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index d99163e..5e18466 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -21,11 +21,9 @@ import System.IO.Error import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens 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 @@ -85,7 +83,7 @@ getRequestMap = foldl' helper emptyIxMap ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m _ -> acc -decodeFromServerMsg :: RequestMap -> B.ByteString -> (FromServerMessage, RequestMap) +decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj where obj = fromJust $ decode bytes :: Value p = parseServerMessage $ \lid -> @@ -93,8 +91,8 @@ decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj in case mm of Nothing -> Nothing Just m -> Just $ (m, Pair m (Const newMap)) - unP (FromServerMess m msg) = (FromServerMess m msg, reqMap) - unP (FromServerRsp (Pair m (Const newMap)) msg) = (FromServerRsp m msg, newMap) + unP (FromServerMess m msg) = (reqMap, FromServerMess m msg) + unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg) {- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 20a40d3..0cd5d42 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -28,24 +28,20 @@ import Control.Concurrent import Control.Lens import Control.Monad.IO.Class import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser hiding (named) import qualified Data.Conduit.Parser (named) +import Data.GADT.Compare import qualified Data.Text as T import Data.Typeable import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Test.Session -import Data.GADT.Compare -import Data.Type.Equality -- $receiving --- To receive a message, just specify the type that expect: +-- To receive a message, specify the method of the message to expect: -- -- @ --- msg1 <- message :: Session ApplyWorkspaceEditRequest --- msg2 <- message :: Session HoverResponse +-- msg1 <- message SWorkspaceApplyEdit +-- msg2 <- message STextDocumentHover -- @ -- -- 'Language.Haskell.LSP.Test.Session' is actually just a parser @@ -56,15 +52,15 @@ import Data.Type.Equality -- For example, if you wanted to match either a definition or -- references request: -- --- > defOrImpl = (message :: Session DefinitionRequest) --- > <|> (message :: Session ReferencesRequest) +-- > defOrImpl = message STextDocumentDefinition +-- > <|> message STextDocumentReferences -- -- If you wanted to match any number of telemetry -- notifications immediately followed by a response: -- -- @ -- logThenDiags = --- skipManyTill (message :: Session TelemetryNotification) +-- skipManyTill (message STelemetryEvent) -- anyResponse -- @ @@ -78,7 +74,10 @@ satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) -- -- @since 0.6.1.0 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a -satisfyMaybe pred = do +satisfyMaybe pred = satisfyMaybeM (pure . pred) + +satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a +satisfyMaybeM pred = do skipTimeout <- overridingTimeout <$> get timeoutId <- getCurTimeoutId @@ -95,7 +94,9 @@ satisfyMaybe pred = do modify $ \s -> s { lastReceivedMessage = Just x } - case pred x of + res <- pred x + + case res of Just a -> do logMsg LogServer x return a @@ -114,6 +115,16 @@ mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of pure HRefl _ -> Nothing +mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2) +mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of + (IsClientNot, IsClientNot) -> do + Refl <- geq m1 m2 + pure HRefl + (IsClientReq, IsClientReq) -> do + Refl <- geq m1 m2 + pure HRefl + _ -> Nothing + message :: SServerMethod m -> Session (ServerMessage m) message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case FromServerMess m2 msg -> do @@ -144,12 +155,17 @@ anyResponse = named "Any response" $ satisfy $ \case FromServerRsp _ _ -> True -- | Matches a response for a specific id. -responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m) -responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do +responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m) +responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do satisfyMaybe $ \msg -> do case msg of FromServerMess _ _ -> Nothing - FromServerRsp m rsp -> undefined -- TODO + FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> + case mEqClient m m' of + Just HRefl -> do + guard (lid' == Just lid) + pure rspMsg + Nothing -> empty -- | Matches any type of message. anyMessage :: Session FromServerMessage -- 2.30.2