X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=09006b67859957aedab3ac045a3926ad09598037;hb=ae9d99b56df5468816e476059f59537da18fab9c;hp=892f33046771e91608dc0fd85db13b08a66524c1;hpb=df782ad008b840c0860173821226542e2e70f2e9;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 892f330..09006b6 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,131 +1,147 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.LSP.Test.Parsing where -import Prelude hiding ( id ) -import Data.Aeson +module Language.Haskell.LSP.Test.Parsing + ( -- $receiving + satisfy + , message + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + , responseForId + ) where + +import Control.Applicative +import Control.Concurrent import Control.Lens +import Control.Monad.IO.Class +import Control.Monad +import Data.Aeson 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 +import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Session + +-- $receiving +-- To receive a message, just specify the type that expect: +-- +-- @ +-- msg1 <- message :: Session ApplyWorkspaceEditRequest +-- msg2 <- message :: Session HoverResponse +-- @ +-- +-- 'Language.Haskell.LSP.Test.Session' is actually just a parser +-- that operates on messages under the hood. This means that you +-- can create and combine parsers to match speicifc sequences of +-- messages that you expect. +-- +-- For example, if you wanted to match either a definition or +-- references request: +-- +-- > defOrImpl = (message :: Session DefinitionRequest) +-- > <|> (message :: Session ReferencesRequest) +-- +-- If you wanted to match any number of telemetry +-- notifications immediately followed by a response: +-- +-- @ +-- logThenDiags = +-- skipManyTill (message :: Session TelemetryNotification) +-- 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 + + 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 + logMsg LogServer x + 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 + +-- | Matches a response for a specific id. +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 + +-- | 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 +encodeMsg = encode . 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" \ No newline at end of file + shouldSkip (NotLogMessage _) = True + shouldSkip (NotShowMessage _) = True + shouldSkip (ReqShowMessage _) = True + shouldSkip _ = False + +-- | 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