+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Parsing where
-import Prelude hiding ( id )
-import Data.Aeson
+import Control.Applicative
+import Control.Concurrent
import Control.Lens
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy.Char8 as B
+import Data.Conduit.Parser
import Data.Maybe
-import System.IO
-import Language.Haskell.LSP.Types
- hiding ( error )
+import qualified Data.Text as T
+import Data.Typeable
import Language.Haskell.LSP.Messages
-import qualified Data.HashMap.Strict as HM
-
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
- done <- hIsEOF h
- if done
- then return []
- else do
- msg <- getNextMessage h
-
- (msg :) <$> getAllMessages h
-
--- | Fetches the next message bytes based on
--- the Content-Length header
-getNextMessage :: Handle -> IO B.ByteString
-getNextMessage h = do
- headers <- getHeaders h
- case read . init <$> lookup "Content-Length" headers of
- Nothing -> error "Couldn't read Content-Length header"
- Just size -> B.hGet h size
-
-addHeader :: B.ByteString -> B.ByteString
-addHeader content = B.concat
- [ "Content-Length: "
- , B.pack $ show $ B.length content
- , "\r\n"
- , "\r\n"
- , content
- ]
-
-getHeaders :: Handle -> IO [(String, String)]
-getHeaders h = do
- l <- hGetLine h
- let (name, val) = span (/= ':') l
- if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
-
-type RequestMap = HM.HashMap LspId FromClientMessage
-
-getRequestMap :: [FromClientMessage] -> RequestMap
-getRequestMap = foldl helper HM.empty
+import Language.Haskell.LSP.Types as LSP hiding (error)
+import Language.Haskell.LSP.Test.Messages
+import Language.Haskell.LSP.Test.Session
+import System.Console.ANSI
+
+satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
+satisfy pred = do
+
+ skipTimeout <- overridingTimeout <$> get
+ timeoutId <- curTimeoutId <$> get
+ unless skipTimeout $ do
+ chan <- asks messageChan
+ timeout <- asks (messageTimeout . config)
+ void $ liftIO $ forkIO $ do
+ threadDelay (timeout * 1000000)
+ writeChan chan (TimeoutMessage timeoutId)
+
+ x <- await
+
+ unless skipTimeout $
+ modify $ \s -> s { curTimeoutId = timeoutId + 1 }
+
+ modify $ \s -> s { lastReceivedMessage = Just x }
+
+ if pred x
+ then do
+ shouldLog <- asks $ logMessages . config
+ liftIO $ when shouldLog $ do
+ setSGR [SetColor Foreground Dull Magenta]
+ putStrLn $ "<-- " ++ B.unpack (encodeMsgPretty x)
+ setSGR [Reset]
+ return x
+ else empty
+
+-- | 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)
+
+-- | Matches if the message is a notification.
+anyNotification :: Session FromServerMessage
+anyNotification = named "Any notification" $ satisfy isServerNotification
+
+-- | Matches if the message is a request.
+anyRequest :: Session FromServerMessage
+anyRequest = named "Any request" $ satisfy isServerRequest
+
+-- | Matches if the message is a response.
+anyResponse :: Session FromServerMessage
+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
+
+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
+encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
+
+encodeMsgPretty :: FromServerMessage -> B.ByteString
+encodeMsgPretty = encodePretty . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
+
+-- | Matches if the message is a log message notification or a show message notification/request.
+loggingNotification :: Session FromServerMessage
+loggingNotification = named "Logging notification" $ satisfy shouldSkip
where
- helper acc msg = case msg of
- (ReqInitialize val) -> insert val msg acc
- (ReqShutdown val) -> insert val msg acc
- (ReqHover val) -> insert val msg acc
- (ReqCompletion val) -> insert val msg acc
- (ReqCompletionItemResolve val) -> insert val msg acc
- (ReqSignatureHelp val) -> insert val msg acc
- (ReqDefinition val) -> insert val msg acc
- (ReqFindReferences val) -> insert val msg acc
- (ReqDocumentHighlights val) -> insert val msg acc
- (ReqDocumentSymbols val) -> insert val msg acc
- (ReqWorkspaceSymbols val) -> insert val msg acc
- (ReqCodeAction val) -> insert val msg acc
- (ReqCodeLens val) -> insert val msg acc
- (ReqCodeLensResolve val) -> insert val msg acc
- (ReqDocumentFormatting val) -> insert val msg acc
- (ReqDocumentRangeFormatting val) -> insert val msg acc
- (ReqDocumentOnTypeFormatting val) -> insert val msg acc
- (ReqRename val) -> insert val msg acc
- (ReqExecuteCommand val) -> insert val msg acc
- (ReqDocumentLink val) -> insert val msg acc
- (ReqDocumentLinkResolve val) -> insert val msg acc
- (ReqWillSaveWaitUntil val) -> insert val msg acc
- _ -> acc
- insert m = HM.insert (m ^. id)
-
-matchResponseMsgType :: FromClientMessage -> B.ByteString -> FromServerMessage
-matchResponseMsgType req bytes = case req of
- ReqInitialize _ -> RspInitialize $ fromJust $ decode bytes
- ReqShutdown _ -> RspShutdown $ fromJust $ decode bytes
- ReqHover _ -> RspHover $ fromJust $ decode bytes
- ReqCompletion _ -> RspCompletion $ fromJust $ decode bytes
- ReqCompletionItemResolve _ ->
- RspCompletionItemResolve $ fromJust $ decode bytes
- ReqSignatureHelp _ -> RspSignatureHelp $ fromJust $ decode bytes
- ReqDefinition _ -> RspDefinition $ fromJust $ decode bytes
- ReqFindReferences _ -> RspFindReferences $ fromJust $ decode bytes
- ReqDocumentHighlights _ -> RspDocumentHighlights $ fromJust $ decode bytes
- ReqDocumentSymbols _ -> RspDocumentSymbols $ fromJust $ decode bytes
- ReqWorkspaceSymbols _ -> RspWorkspaceSymbols $ fromJust $ decode bytes
- ReqCodeAction _ -> RspCodeAction $ fromJust $ decode bytes
- ReqCodeLens _ -> RspCodeLens $ fromJust $ decode bytes
- ReqCodeLensResolve _ -> RspCodeLensResolve $ fromJust $ decode bytes
- ReqDocumentFormatting _ -> RspDocumentFormatting $ fromJust $ decode bytes
- ReqDocumentRangeFormatting _ ->
- RspDocumentRangeFormatting $ fromJust $ decode bytes
- ReqDocumentOnTypeFormatting _ ->
- RspDocumentOnTypeFormatting $ fromJust $ decode bytes
- ReqRename _ -> RspRename $ fromJust $ decode bytes
- ReqExecuteCommand _ -> RspExecuteCommand $ fromJust $ decode bytes
- ReqDocumentLink _ -> RspDocumentLink $ fromJust $ decode bytes
- ReqDocumentLinkResolve _ -> RspDocumentLinkResolve $ fromJust $ decode bytes
- ReqWillSaveWaitUntil _ -> RspWillSaveWaitUntil $ fromJust $ decode bytes
- x -> error $ "Not a request: " ++ show x
-
-decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
-decodeFromServerMsg reqMap bytes =
- case HM.lookup "method" (fromJust $ decode bytes :: Object) of
- Just methodStr -> case fromJSON methodStr of
- Success method -> case method of
- -- We can work out the type of the message
- TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
- WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
- WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
- CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
- TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes
- WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes
- ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes
- ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes
- WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
-
- Error e -> error e
-
- Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
- Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
- Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
- Nothing -> error "Couldn't match up response with request"
- Nothing -> error "Couldn't decode message"
+ shouldSkip (NotLogMessage _) = True
+ shouldSkip (NotShowMessage _) = True
+ shouldSkip (ReqShowMessage _) = True
+ shouldSkip _ = False
+
+publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
+publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
+ NotPublishDiagnostics diags <- satisfy test
+ return diags
+ where test (NotPublishDiagnostics _) = True
+ test _ = False
projects / lsp-test.git / blobdiff