src/Language/Haskell/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE PolyKinds #-}
   4 {-# LANGUAGE KindSignatures #-}
   5 {-# LANGUAGE DataKinds #-}
   6 {-# LANGUAGE GADTs #-}
   7 {-# LANGUAGE LambdaCase #-}
   8 {-# LANGUAGE RankNTypes #-}
   9 {-# LANGUAGE OverloadedStrings #-}
  10
  11 module Language.Haskell.LSP.Test.Parsing
  12   ( -- $receiving
  13     satisfy
  14   , satisfyMaybe
  15   , message
  16   , anyRequest
  17   , anyResponse
  18   , anyNotification
  19   , anyMessage
  20   , loggingNotification
  21   , publishDiagnosticsNotification
  22   , responseForId
  23   ) where
  24
  25 import Control.Applicative
  26 import Control.Concurrent
  27 import Control.Lens
  28 import Control.Monad.IO.Class
  29 import Control.Monad
  30 import Data.Aeson
  31 import qualified Data.ByteString.Lazy.Char8 as B
  32 import Data.Conduit.Parser hiding (named)
  33 import qualified Data.Conduit.Parser (named)
  34 import qualified Data.Text as T
  35 import Data.Typeable
  36 import Language.Haskell.LSP.Types
  37 import qualified Language.Haskell.LSP.Types.Lens as LSP
  38 import Language.Haskell.LSP.Test.Session
  39
  40 -- $receiving
  41 -- To receive a message, just specify the type that expect:
  42 --
  43 -- @
  44 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
  45 -- msg2 <- message :: Session HoverResponse
  46 -- @
  47 --
  48 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
  49 -- that operates on messages under the hood. This means that you
  50 -- can create and combine parsers to match speicifc sequences of
  51 -- messages that you expect.
  52 --
  53 -- For example, if you wanted to match either a definition or
  54 -- references request:
  55 --
  56 -- > defOrImpl = (message :: Session DefinitionRequest)
  57 -- >          <|> (message :: Session ReferencesRequest)
  58 --
  59 -- If you wanted to match any number of telemetry
  60 -- notifications immediately followed by a response:
  61 --
  62 -- @
  63 -- logThenDiags =
  64 --  skipManyTill (message :: Session TelemetryNotification)
  65 --               anyResponse
  66 -- @
  67
  68 -- | Consumes and returns the next message, if it satisfies the specified predicate.
  69 --
  70 -- @since 0.5.2.0
  71 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  72 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
  73
  74 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
  75 --
  76 -- @since 0.6.1.0
  77 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
  78 satisfyMaybe pred = do
  79
  80   skipTimeout <- overridingTimeout <$> get
  81   timeoutId <- getCurTimeoutId
  82   unless skipTimeout $ do
  83     chan <- asks messageChan
  84     timeout <- asks (messageTimeout . config)
  85     void $ liftIO $ forkIO $ do
  86       threadDelay (timeout * 1000000)
  87       writeChan chan (TimeoutMessage timeoutId)
  88
  89   x <- Session await
  90
  91   unless skipTimeout (bumpTimeoutId timeoutId)
  92
  93   modify $ \s -> s { lastReceivedMessage = Just x }
  94
  95   case pred x of
  96     Just a -> do
  97       logMsg LogServer x
  98       return a
  99     Nothing -> empty
 100
 101 named :: T.Text -> Session a -> Session a
 102 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 103
 104 message :: SServerMethod m -> Session (ServerMessage m)
 105 message = undefined -- TODO
 106
 107 -- | Matches if the message is a notification.
 108 anyNotification :: Session FromServerMessage
 109 anyNotification = named "Any notification" $ satisfy $ \case
 110   FromServerMess m _ -> case splitServerMethod m of
 111     IsServerNot -> True
 112     _ -> False
 113   FromServerRsp _ _ -> False
 114
 115 -- | Matches if the message is a request.
 116 anyRequest :: Session FromServerMessage
 117 anyRequest = named "Any request" $ satisfy $ \case
 118   FromServerMess m _ -> case splitServerMethod m of
 119     IsServerReq -> True
 120     _ -> False
 121   FromServerRsp _ _ -> False
 122
 123 -- | Matches if the message is a response.
 124 anyResponse :: Session FromServerMessage
 125 anyResponse = named "Any response" $ satisfy $ \case
 126   FromServerMess _ _ -> False
 127   FromServerRsp _ _ -> True
 128
 129 -- | Matches a response for a specific id.
 130 responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m)
 131 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
 132   satisfyMaybe $ \msg -> do
 133     case msg of
 134       FromServerMess _ _ -> Nothing
 135       FromServerRsp m rsp -> undefined -- TODO
 136
 137 -- | Matches any type of message.
 138 anyMessage :: Session FromServerMessage
 139 anyMessage = satisfy (const True)
 140
 141 -- | Matches if the message is a log message notification or a show message notification/request.
 142 loggingNotification :: Session FromServerMessage
 143 loggingNotification = named "Logging notification" $ satisfy shouldSkip
 144   where
 145     shouldSkip (FromServerMess SWindowLogMessage _) = True
 146     shouldSkip (FromServerMess SWindowShowMessage _) = True
 147     shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
 148     shouldSkip _ = False
 149
 150 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 151 -- (textDocument/publishDiagnostics) notification.
 152 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 153 publishDiagnosticsNotification = named "Publish diagnostics notification" $
 154   satisfyMaybe $ \msg -> case msg of
 155     FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
 156     _ -> Nothing