X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=36841e8be6173406c4347a434d4bf7560e799c8c;hb=ddf9bc17ce8a548a927c201c6b0edb8cf1c9fcad;hp=a6612e2c49c6aaffc3148c44bb285e35d8c46bae;hpb=6d352ac93d32f520a36c530bc42c86f05fd449b7;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index a6612e2..36841e8 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -37,6 +37,7 @@ module Language.Haskell.LSP.Test , module Language.Haskell.LSP.Test.Parsing -- * Utilities -- | Quick helper functions for common tasks. + -- ** Initialization , initializeResponse -- ** Documents @@ -109,10 +110,10 @@ import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Parsing import Language.Haskell.LSP.Test.Session import Language.Haskell.LSP.Test.Server +import System.Environment import System.IO import System.Directory import System.FilePath -import qualified Data.Rope.UTF16 as Rope -- | Starts a new session. -- @@ -136,10 +137,12 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a -runSessionWithConfig config serverExe caps rootDir session = do +runSessionWithConfig config' serverExe caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir + config <- envOverrideConfig config' + let initializeParams = InitializeParams (Just pid) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) @@ -150,9 +153,16 @@ runSessionWithConfig config serverExe caps rootDir session = do withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls - initRspMsg <- request Initialize initializeParams :: Session InitializeResponse + -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse + initReqId <- sendRequest Initialize initializeParams + + -- Because messages can be sent in between the request and response, + -- collect them and then... + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId) - liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error) + case initRspMsg ^. LSP.result of + Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) + Right _ -> pure () initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg @@ -162,6 +172,12 @@ runSessionWithConfig config serverExe caps rootDir session = do Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) Nothing -> return () + -- ... relay them back to the user Session so they can match on them! + -- As long as they are allowed. + forM_ inBetween checkLegalBetweenMessage + msgChan <- asks messageChan + liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween) + -- Run the actual test session where @@ -184,12 +200,33 @@ runSessionWithConfig config serverExe caps rootDir session = do (RspShutdown _) -> return () _ -> listenServer serverOut context + -- | Is this message allowed to be sent by the server between the intialize + -- request and response? + -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize + checkLegalBetweenMessage :: FromServerMessage -> Session () + checkLegalBetweenMessage (NotShowMessage _) = pure () + checkLegalBetweenMessage (NotLogMessage _) = pure () + checkLegalBetweenMessage (NotTelemetry _) = pure () + checkLegalBetweenMessage (ReqShowMessage _) = pure () + checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg) + + -- | Check environment variables to override the config + envOverrideConfig :: SessionConfig -> IO SessionConfig + envOverrideConfig cfg = do + logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES" + logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR" + return $ cfg { logMessages = logMessages', logStdErr = logStdErr' } + where checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> lookupEnv s + convertVal "0" = False + convertVal _ = True + -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri) - return $ Rope.toText $ Language.Haskell.LSP.VFS._text file + return (virtualFileText file) -- | Parses an ApplyEditRequest, checks that it is for the passed document -- and returns the new content @@ -377,12 +414,11 @@ noDiagnostics = do -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) getDocumentSymbols doc = do - ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse - maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr - case mRes of - Just (DSDocumentSymbols (List xs)) -> return (Left xs) - Just (DSSymbolInformation (List xs)) -> return (Right xs) - Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse" + ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse + case res of + Right (DSDocumentSymbols (List xs)) -> return (Left xs) + Right (DSSymbolInformation (List xs)) -> return (Right xs) + Left err -> throw (UnexpectedResponseError rspLid err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult] @@ -391,8 +427,8 @@ getCodeActions doc range = do rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing) case rsp ^. result of - Just (List xs) -> return xs - _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error)) + Right (List xs) -> return xs + Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error) -- | Returns all the code actions in a document by -- querying the code actions at each of the current @@ -406,13 +442,11 @@ getAllCodeActions doc = do where go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] go ctx acc diag = do - ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) + ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) - case mErr of - Just e -> throw (UnexpectedResponseError rspLid e) - Nothing -> - let Just (List cmdOrCAs) = mRes - in return (acc ++ cmdOrCAs) + case res of + Left e -> throw (UnexpectedResponseError rspLid e) + Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs) getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext getCodeActionContext doc = do @@ -452,7 +486,7 @@ getVersionedDoc (TextDocumentIdentifier uri) = do fs <- vfsMap . vfs <$> get let ver = case fs Map.!? toNormalizedUri uri of - Just (VirtualFile v _) -> Just v + Just vf -> Just (virtualFileVersion vf) _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) @@ -546,9 +580,10 @@ getHighlights doc pos = -- | Checks the response for errors and throws an exception if needed. -- Returns the result if successful. getResponseResult :: ResponseMessage a -> a -getResponseResult rsp = fromMaybe exc (rsp ^. result) - where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id) - (fromJust $ rsp ^. LSP.error) +getResponseResult rsp = + case rsp ^. result of + Right x -> x + Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()