X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=92ab99faea5898c646f888f25aaed22bf50968df;hb=84e2707604b3a64c00062104fa40e2ea76040155;hp=0cd5d427b635ecccebe6d9575f3428ddebf882ab;hpb=f2862c89be8f545d0cda5890dce58d31c15127f6;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 0cd5d42..92ab99f 100644
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PolyKinds #-}
@@ -14,23 +15,24 @@ module Language.Haskell.LSP.Test.Parsing
     satisfy
   , satisfyMaybe
   , message
+  , response
+  , responseForId
+  , customRequest
+  , customNotification
   , anyRequest
   , anyResponse
   , anyNotification
   , anyMessage
   , loggingNotification
   , publishDiagnosticsNotification
-  , responseForId
   ) where
 
 import Control.Applicative
 import Control.Concurrent
-import Control.Lens
 import Control.Monad.IO.Class
 import Control.Monad
 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
@@ -105,38 +107,41 @@ satisfyMaybeM pred = do
 named :: T.Text -> Session a -> Session a
 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 
-mEq :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2)
-mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of
-  (IsServerNot, IsServerNot) -> do
-    Refl <- geq m1 m2
-    pure HRefl
-  (IsServerReq, IsServerReq) -> do
-    Refl <- geq m1 m2
-    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
 
+-- | 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
   FromServerMess m2 msg -> do
-    HRefl <- mEq m1 m2
+    HRefl <- mEqServer m1 m2
     pure msg
   _ -> Nothing
 
+customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
+customRequest m = named m $ satisfyMaybe $ \case
+  FromServerMess m1 msg -> case splitServerMethod m1 of
+    IsServerEither -> case msg of
+      ReqMess _ | m1 == SCustomMethod m -> Just msg
+      _ -> Nothing
+    _ -> Nothing
+  _ -> Nothing
+
+customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
+customNotification m = named m $ satisfyMaybe $ \case
+  FromServerMess m1 msg -> case splitServerMethod m1 of
+    IsServerEither -> case msg of
+      NotMess _ | m1 == SCustomMethod m -> Just msg
+      _ -> Nothing
+    _ -> Nothing
+  _ -> Nothing
+
 -- | Matches if the message is a notification.
 anyNotification :: Session FromServerMessage
 anyNotification = named "Any notification" $ satisfy $ \case
-  FromServerMess m _ -> case splitServerMethod m of
+  FromServerMess m msg -> case splitServerMethod m of
     IsServerNot -> True
+    IsServerEither -> case msg of
+      NotMess _ -> True
+      _ -> False
     _ -> False
   FromServerRsp _ _ -> False
 
@@ -154,7 +159,15 @@ anyResponse = named "Any response" $ satisfy $ \case
   FromServerMess _ _ -> False
   FromServerRsp _ _ -> True
 
--- | Matches a response for a specific id.
+-- | 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
+  FromServerRsp m2 msg -> do
+    HRefl <- mEqClient m1 m2
+    pure msg
+  _ -> Nothing
+
+-- | Like 'response', but matches a response for a specific id.
 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
@@ -165,7 +178,12 @@ responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
           Just HRefl -> do
             guard (lid' == Just lid)
             pure rspMsg
-          Nothing -> empty
+          Nothing
+            | SCustomMethod tm <- m
+            , SCustomMethod tm' <- m'
+            , tm == tm'
+            , lid' == Just lid -> pure rspMsg
+          _ -> empty
 
 -- | Matches any type of message.
 anyMessage :: Session FromServerMessage