X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=36841e8be6173406c4347a434d4bf7560e799c8c;hb=ddf9bc17ce8a548a927c201c6b0edb8cf1c9fcad;hp=b098bf723ec559763951fd3bde1e991837661751;hpb=e947642c734b4dd081e59b2afcaf3228d1b2f5a9;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index b098bf7..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 @@ -273,7 +310,7 @@ sendNotification TextDocumentDidOpen params = do n :: DidOpenTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidOpen params' oldVFS <- vfs <$> get - newVFS <- liftIO $ openVFS oldVFS n + let (newVFS,_) = openVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -283,7 +320,7 @@ sendNotification TextDocumentDidClose params = do n :: DidCloseTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidClose params' oldVFS <- vfs <$> get - newVFS <- liftIO $ closeVFS oldVFS n + let (newVFS,_) = closeVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -292,7 +329,7 @@ sendNotification TextDocumentDidChange params = do n :: DidChangeTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidChange params' oldVFS <- vfs <$> get - newVFS <- liftIO $ changeFromClientVFS oldVFS n + let (newVFS,_) = changeFromClientVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -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 ()