X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=3ba86905c2d48d6c015812421253fa7319f3a3e6;hb=c6e68648c1e3b586e1ee8b0dcda1485ff5ae28ba;hp=b406e7bd4e87a5a068d59b44e7b27678b100a64e;hpb=3b8d5fe55d1e542587817341a797345270ca7a96;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index b406e7b..3ba8690 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -19,9 +19,9 @@ module Language.Haskell.LSP.Test , runSessionWithConfig , Session , SessionConfig(..) - , MonadSessionConfig(..) , SessionException(..) , anySessionException + , withTimeout -- * Sending , sendRequest , sendRequest_ @@ -31,35 +31,14 @@ module Language.Haskell.LSP.Test , sendNotification' , sendResponse -- * Receving + , message , anyRequest - , request , anyResponse - , response , anyNotification - , notification , anyMessage , loggingNotification , publishDiagnosticsNotification -- * Combinators - , choice - , option - , optional - , between - , some - , many - , sepBy - , sepBy1 - , sepEndBy1 - , sepEndBy - , endBy1 - , endBy - , count - , manyTill - , skipMany - , skipSome - , skipManyTill - , skipSomeTill - , (<|>) , satisfy -- * Utilities , initializeResponse @@ -68,6 +47,7 @@ module Language.Haskell.LSP.Test , documentContents , getDocumentEdit , getDocUri + , getVersionedDoc -- ** Symbols , getDocumentSymbols -- ** Diagnostics @@ -78,9 +58,12 @@ module Language.Haskell.LSP.Test -- ** Code Actions , getAllCodeActions , executeCodeAction + -- ** Completions + , getCompletions + -- ** Edits + , applyEdit ) where -import Control.Applicative import Control.Applicative.Combinators import Control.Concurrent import Control.Monad @@ -94,8 +77,9 @@ import Data.Default import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe -import Language.Haskell.LSP.Types hiding (id, capabilities, error) +import Language.Haskell.LSP.Types hiding (id, capabilities, message) import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat @@ -151,20 +135,19 @@ runSessionWithConfig config serverExe rootDir session = do sendNotification Exit ExitParams return result - + where -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores -listenServer :: Handle -> Session () -listenServer serverOut = do - msgBytes <- liftIO $ getNextMessage serverOut + listenServer :: Handle -> SessionContext -> IO () + listenServer serverOut context = do + msgBytes <- getNextMessage serverOut - context <- ask - reqMap <- liftIO $ readMVar $ requestMap context + reqMap <- readMVar $ requestMap context let msg = decodeFromServerMsg reqMap msgBytes - liftIO $ writeChan (messageChan context) msg + writeChan (messageChan context) (ServerMessage msg) - listenServer serverOut + listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text @@ -177,10 +160,10 @@ documentContents doc = do -- and returns the new content getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do - req <- request :: Session ApplyWorkspaceEditRequest + req <- message :: Session ApplyWorkspaceEditRequest unless (checkDocumentChanges req || checkChanges req) $ - liftIO $ throw (IncorrectApplyEditRequestException (show req)) + liftIO $ throw (IncorrectApplyEditRequest (show req)) documentContents doc where @@ -316,9 +299,10 @@ getDocUri file = do let fp = rootDir context file return $ filePathToUri fp +-- | Waits for diagnostics to be published and returns them. waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do - diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification + diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. params . LSP.diagnostics return diags @@ -327,8 +311,8 @@ waitForDiagnostics = do -- returned. noDiagnostics :: Session () noDiagnostics = do - diagsNot <- notification :: Session PublishDiagnosticsNotification - when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException + diagsNot <- message :: Session PublishDiagnosticsNotification + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] @@ -338,6 +322,9 @@ getDocumentSymbols doc = do let (Just (List symbols)) = mRes return symbols +-- | Returns all the code actions in a document by +-- querying the code actions at each of the current +-- diagnostics' positions. getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction] getAllCodeActions doc = do curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get @@ -356,12 +343,17 @@ getAllCodeActions doc = do let Just (List cmdOrCAs) = mRes in return (acc ++ cmdOrCAs) +-- | Executes a command. executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams (cmd ^. command) args sendRequest_ WorkspaceExecuteCommand execParams +-- | Executes a code action. +-- Matching with the specification, if a code action +-- contains both an edit and a command, the edit will +-- be applied first. executeCodeAction :: CodeAction -> Session () executeCodeAction action = do maybe (return ()) handleEdit $ action ^. edit @@ -369,5 +361,56 @@ executeCodeAction action = do where handleEdit :: WorkspaceEdit -> Session () handleEdit e = + -- Its ok to pass in dummy parameters here as they aren't used let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) - in processMessage (ReqApplyWorkspaceEdit req) \ No newline at end of file + in updateState (ReqApplyWorkspaceEdit req) + +-- | Adds the current version to the document, as tracked by the session. +getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier +getVersionedDoc (TextDocumentIdentifier uri) = do + fs <- vfs <$> get + let ver = + case fs Map.!? uri of + Just (VirtualFile v _) -> Just v + _ -> Nothing + return (VersionedTextDocumentIdentifier uri ver) + +-- | Applys an edit to the document and returns the updated document version. +applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier +applyEdit doc edit = do + + verDoc <- getVersionedDoc doc + + caps <- asks (capabilities . config) + + let supportsDocChanges = fromMaybe False $ do + let LSP.ClientCapabilities mWorkspace _ _ = caps + LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace + LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit + mDocChanges + + let wEdit = if supportsDocChanges + then + let docEdit = TextDocumentEdit verDoc (List [edit]) + in WorkspaceEdit Nothing (Just (List [docEdit])) + else + let changes = HashMap.singleton (doc ^. uri) (List [edit]) + in WorkspaceEdit (Just changes) Nothing + + let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + updateState (ReqApplyWorkspaceEdit req) + + -- version may have changed + getVersionedDoc doc + +-- | Returns the completions for the position in the document. +getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] +getCompletions doc pos = do + rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos) + + let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id) + (fromJust $ rsp ^. LSP.error) + res = fromMaybe exc (rsp ^. result) + case res of + Completions (List items) -> return items + CompletionList (CompletionListType _ (List items)) -> return items