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

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