projects
/
lsp-test.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add notice that this was merged into haskell/lsp
[lsp-test.git]
/
src
/
Language
/
LSP
/
Test
/
Parsing.hs
diff --git
a/src/Language/LSP/Test/Parsing.hs
b/src/Language/LSP/Test/Parsing.hs
index 95937c51c11fca122f8d0bafd7735a38f64169c0..247f969862f2ad25a42ad3dc10e6de4802509201 100644
(file)
--- a/
src/Language/LSP/Test/Parsing.hs
+++ b/
src/Language/LSP/Test/Parsing.hs
@@
-4,7
+4,7
@@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE
DataKinds
#-}
+{-# LANGUAGE
TypeInType
#-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
@@
-83,16
+83,21
@@
satisfyMaybeM pred = do
skipTimeout <- overridingTimeout <$> get
timeoutId <- getCurTimeoutId
skipTimeout <- overridingTimeout <$> get
timeoutId <- getCurTimeoutId
- unless skipTimeout $ do
+ mtid <-
+ if skipTimeout
+ then pure Nothing
+ else Just <$> do
chan <- asks messageChan
timeout <- asks (messageTimeout . config)
chan <- asks messageChan
timeout <- asks (messageTimeout . config)
-
void $
liftIO $ forkIO $ do
+
liftIO $ forkIO $ do
threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
x <- Session await
threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
x <- Session await
- unless skipTimeout (bumpTimeoutId timeoutId)
+ forM_ mtid $ \tid -> do
+ bumpTimeoutId timeoutId
+ liftIO $ killThread tid
modify $ \s -> s { lastReceivedMessage = Just x }
modify $ \s -> s { lastReceivedMessage = Just x }
@@
-110,10
+115,12
@@
named s (Session x) = Session (Data.Conduit.Parser.named s x)
-- | Matches a request or a notification coming from the server.
message :: SServerMethod m -> Session (ServerMessage m)
-- | Matches a request or a notification coming from the server.
message :: SServerMethod m -> Session (ServerMessage m)
-message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+message m1 = named (T.pack $
"Request for: " <>
show m1) $ satisfyMaybe $ \case
FromServerMess m2 msg -> do
FromServerMess m2 msg -> do
- HRefl <- mEqServer m1 m2
- pure msg
+ res <- mEqServer m1 m2
+ case res of
+ Right HRefl -> pure msg
+ Left f -> Nothing
_ -> Nothing
customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
_ -> Nothing
customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
@@
-161,9
+168,9
@@
anyResponse = named "Any response" $ satisfy $ \case
-- | Matches a response coming from the server.
response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
-- | Matches a response coming from the server.
response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
-response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+response m1 = named (T.pack $
"Response for: " <>
show m1) $ satisfyMaybe $ \case
FromServerRsp m2 msg -> do
FromServerRsp m2 msg -> do
- HRefl <- mEqClient m1 m2
+ HRefl <-
runEq
mEqClient m1 m2
pure msg
_ -> Nothing
pure msg
_ -> Nothing
@@
-173,17
+180,10
@@
responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
satisfyMaybe $ \msg -> do
case msg of
FromServerMess _ _ -> Nothing
satisfyMaybe $ \msg -> do
case msg of
FromServerMess _ _ -> Nothing
- FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
- case mEqClient m m' of
- Just HRefl -> do
- guard (lid' == Just lid)
+ FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do
+ HRefl <- runEq mEqClient m m'
+ guard (Just lid == lid')
pure rspMsg
pure rspMsg
- Nothing
- | SCustomMethod tm <- m
- , SCustomMethod tm' <- m'
- , tm == tm'
- , lid' == Just lid -> pure rspMsg
- _ -> empty
-- | Matches any type of message.
anyMessage :: Session FromServerMessage
-- | Matches any type of message.
anyMessage :: Session FromServerMessage
@@
-198,9
+198,9
@@
loggingNotification = named "Logging notification" $ satisfy shouldSkip
shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
shouldSkip _ = False
shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
shouldSkip _ = False
--- | Matches a 'Language.LSP.T
est.PublishDiagnosticsNotification
'
+-- | Matches a 'Language.LSP.T
ypes.TextDocumentPublishDiagnostics
'
-- (textDocument/publishDiagnostics) notification.
-- (textDocument/publishDiagnostics) notification.
-publishDiagnosticsNotification :: Session
PublishDiagnosticsNotification
+publishDiagnosticsNotification :: Session
(Message TextDocumentPublishDiagnostics)
publishDiagnosticsNotification = named "Publish diagnostics notification" $
satisfyMaybe $ \msg -> case msg of
FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
publishDiagnosticsNotification = named "Publish diagnostics notification" $
satisfyMaybe $ \msg -> case msg of
FromServerMess STextDocumentPublishDiagnostics diags -> Just diags