X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=0810d20c0f56f45909ef5b3d30c79b78c34019de;hb=1294a1fbb1578d87cc1fb4c10bc5f91e54cf9904;hp=128cfb4018a4e9ce40bbabe86a86ac66f4edae22;hpb=d1855cd1182c51333c82bf964fc96c8ec3ec76b7;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 128cfb4..0810d20 100644
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -5,7 +5,8 @@
 
 module Language.Haskell.LSP.Test.Parsing
   ( -- $receiving
-    message
+    satisfy
+  , message
   , anyRequest
   , anyResponse
   , anyNotification
@@ -23,11 +24,11 @@ import Control.Monad
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Conduit.Parser
-import Data.Maybe
 import qualified Data.Text as T
 import Data.Typeable
 import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types as LSP hiding (error, message)
+import Language.Haskell.LSP.Types
+import qualified Language.Haskell.LSP.Types.Lens as LSP
 import Language.Haskell.LSP.Test.Messages
 import Language.Haskell.LSP.Test.Session
 
@@ -59,8 +60,17 @@ import Language.Haskell.LSP.Test.Session
 --               anyResponse
 -- @
 
+-- | Consumes and returns the next message, if it satisfies the specified predicate.
+--
+-- @since 0.5.2.0
 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
-satisfy pred = do
+satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
+
+-- | Consumes and returns the result of the specified predicate if it returns `Just`.
+--
+-- @since 0.5.3.0
+satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
+satisfyMaybe pred = do
 
   skipTimeout <- overridingTimeout <$> get
   timeoutId <- curTimeoutId <$> get
@@ -78,18 +88,18 @@ satisfy pred = do
 
   modify $ \s -> s { lastReceivedMessage = Just x }
 
-  if pred x
-    then do
+  case pred x of
+    Just a -> do
       logMsg LogServer x
-      return x
-    else empty
+      return a
+    Nothing -> empty
 
--- | Matches a message of type 'a'.
+-- | 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) $
-    castMsg <$> satisfy (isJust . parser)
+     satisfyMaybe parser
 
 -- | Matches if the message is a notification.
 anyNotification :: Session FromServerMessage
@@ -107,17 +117,15 @@ anyResponse = named "Any response" $ satisfy isServerResponse
 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
-  x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
-  return $ castMsg x
+  satisfyMaybe $ \msg -> do
+    z <- parser msg
+    guard (z ^. LSP.id == responseId lid)
+    pure z
 
 -- | Matches any type of message.
 anyMessage :: Session FromServerMessage
 anyMessage = satisfy (const True)
 
--- | A stupid method for getting out the inner message.
-castMsg :: FromJSON a => FromServerMessage -> a
-castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
-
 -- | A version of encode that encodes FromServerMessages as if they
 -- weren't wrapped.
 encodeMsg :: FromServerMessage -> B.ByteString
@@ -135,8 +143,7 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip
 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 -- (textDocument/publishDiagnostics) notification.
 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
-publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
-  NotPublishDiagnostics diags <- satisfy test
-  return diags
-  where test (NotPublishDiagnostics _) = True
-        test _ = False
+publishDiagnosticsNotification = named "Publish diagnostics notification" $
+  satisfyMaybe $ \msg -> case msg of
+    NotPublishDiagnostics diags -> Just diags
+    _ -> Nothing