+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Parsing where
-import Prelude hiding ( id )
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
import Data.Aeson
-import Control.Lens
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 Language.Haskell.LSP.Messages
-import qualified Data.HashMap.Strict as HM
+import Language.Haskell.LSP.Types hiding (error)
+import Language.Haskell.LSP.Test.Exceptions
+import Language.Haskell.LSP.Test.Messages
+import Language.Haskell.LSP.Test.Session
+import System.Console.ANSI
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
- done <- hIsEOF h
- if done
- then return []
- else do
- msg <- getNextMessage h
+satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage
+satisfy pred = do
+ timeout <- timeout <$> lift sessionConfig
+ tId <- liftIO myThreadId
+ timeoutThread <- liftIO $ forkIO $ do
+ threadDelay (timeout * 1000000)
+ throwTo tId TimeoutException
+ x <- await
+ liftIO $ killThread timeoutThread
- (msg :) <$> getAllMessages h
+ if pred x
+ then do
+ liftIO $ do
+ setSGR [SetColor Foreground Vivid Magenta]
+ putStrLn $ "<-- " ++ B.unpack (encodeMsg x)
+ setSGR [Reset]
+ return x
+ else empty
--- | 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
+-- | Matches if the message is a notification.
+anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+anyNotification = named "Any notification" $ satisfy isServerNotification
-addHeader :: B.ByteString -> B.ByteString
-addHeader content = B.concat
- [ "Content-Length: "
- , B.pack $ show $ B.length content
- , "\r\n"
- , "\r\n"
- , content
- ]
+notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
+notification = named "Notification" $ do
+ let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
+ x <- satisfy (isJust . parser)
+ return $ castMsg x
-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
+-- | Matches if the message is a request.
+anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+anyRequest = named "Any request" $ satisfy isServerRequest
-type RequestMap = HM.HashMap LspId FromClientMessage
+request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
+request = named "Request" $ do
+ let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
+ x <- satisfy (isJust . parser)
+ return $ castMsg x
-getRequestMap :: [FromClientMessage] -> RequestMap
-getRequestMap = foldl helper HM.empty
- 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)
+-- | Matches if the message is a response.
+anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+anyResponse = named "Any response" $ satisfy isServerResponse
+
+response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
+response = named "Response" $ do
+ let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
+ x <- satisfy (isJust . parser)
+ return $ castMsg x
-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
+-- | A stupid method for getting out the inner message.
+castMsg :: FromJSON a => FromServerMessage -> a
+castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
-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
+-- | A version of encode that encodes FromServerMessages as if they
+-- weren't wrapped.
+encodeMsg :: FromServerMessage -> B.ByteString
+encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
- Error e -> error e
+-- | Matches if the message is a log message notification or a show message notification/request.
+loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+loggingNotification = named "Logging notification" $ satisfy shouldSkip
+ where
+ shouldSkip (NotLogMessage _) = True
+ shouldSkip (NotShowMessage _) = True
+ shouldSkip (ReqShowMessage _) = True
+ shouldSkip _ = False
- 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"
+publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
+publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
+ NotPublishDiagnostics diags <- satisfy test
+ return diags
+ where test (NotPublishDiagnostics _) = True
+ test _ = False
\ No newline at end of file
projects / opengl.git / blobdiff