X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=430ac5b9153df91469590b6f772b14b2aaf6ccc9;hb=6fa77d1acd9f1c76383ac179b36bacd9d22f2819;hp=845ff2593464b482f3b1d447ef113a2983d5d2d2;hpb=8b2c929b82594c3c95a94852a06e9f4a733d40f6;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 845ff25..430ac5b 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} @@ -24,8 +25,9 @@ module Language.Haskell.LSP.Test -- * Sessions Session , runSession - -- ** Config , runSessionWithConfig + , runSessionWithHandles + -- ** Config , SessionConfig(..) , defaultConfig , C.fullCaps @@ -72,8 +74,10 @@ module Language.Haskell.LSP.Test -- ** References , getReferences -- ** Definitions + , getDeclarations , getDefinitions , getTypeDefinitions + , getImplementations -- ** Renaming , rename -- ** Hover @@ -96,7 +100,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Control.Exception -import Control.Lens hiding ((.=), List) +import Control.Lens hiding ((.=), List, Empty) import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.IO as T @@ -121,6 +125,7 @@ import System.Environment import System.IO import System.Directory import System.FilePath +import System.Process (ProcessHandle) import qualified System.FilePath.Glob as Glob -- | Starts a new session. @@ -146,27 +151,61 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> Session a -- ^ The session to run. -> IO a runSessionWithConfig config' serverExe caps rootDir session = do + config <- envOverrideConfig config' + withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> + runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session + +-- | Starts a new session, using the specified handles to communicate with the +-- server. You can use this to host the server within the same process. +-- An example with haskell-lsp might look like: +-- +-- > (hinRead, hinWrite) <- createPipe +-- > (houtRead, houtWrite) <- createPipe +-- > +-- > forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks handlers def +-- > Test.runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do +-- > -- ... +runSessionWithHandles :: Handle -- ^ The input handle + -> Handle -- ^ The output handle + -> SessionConfig + -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> FilePath -- ^ The filepath to the root directory for the session. + -> Session a -- ^ The session to run. + -> IO a +runSessionWithHandles = runSessionWithHandles' Nothing + + +runSessionWithHandles' :: Maybe ProcessHandle + -> Handle -- ^ The input handle + -> Handle -- ^ The output handle + -> SessionConfig + -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> FilePath -- ^ The filepath to the root directory for the session. + -> Session a -- ^ The session to run. + -> IO a +runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir config <- envOverrideConfig config' - let initializeParams = InitializeParams (Just pid) + let initializeParams = InitializeParams Nothing + (Just pid) + (Just lspTestClientInfo) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) Nothing caps (Just TraceOff) - Nothing - withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> - runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do + (List <$> initialWorkspaceFolders config) + runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse initReqId <- sendRequest SInitialize initializeParams -- Because messages can be sent in between the request and response, -- collect them and then... - (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId) + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId) case initRspMsg ^. LSP.result of Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) @@ -191,7 +230,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do where -- | Asks the server to shutdown and exit politely exitServer :: Session () - exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit (Just ExitParams) + exitServer = request_ SShutdown Empty >> sendNotification SExit Empty -- | Listens to the server output until the shutdown ack, -- makes sure it matches the record and signals any semaphores @@ -199,9 +238,8 @@ runSessionWithConfig config' serverExe caps rootDir session = do listenServer serverOut context = do msgBytes <- getNextMessage serverOut - reqMap <- readMVar $ requestMap context - - let msg = decodeFromServerMsg reqMap msgBytes + msg <- modifyMVar (requestMap context) $ \reqMap -> + pure $ decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) case msg of @@ -266,7 +304,7 @@ getDocumentEdit doc = do -- @ -- Note: will skip any messages in between the request and the response. request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m) -request m = sendRequest m >=> skipManyTill anyMessage . responseForId +request m = sendRequest m >=> skipManyTill anyMessage . responseForId m -- | The same as 'sendRequest', but discard the response. request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session () @@ -355,8 +393,10 @@ createDoc file languageId contents = do rootDir <- asks rootDir caps <- asks sessionCapabilities absFile <- liftIO $ canonicalizePath (rootDir file) - let regs = filter (\r -> r ^. method == SomeClientMethod SWorkspaceDidChangeWatchedFiles) $ - Map.elems dynCaps + let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles] + pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] + pred _ = mempty + regs = concatMap pred $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool watchHits (FileSystemWatcher pattern kind) = -- If WatchKind is exlcuded, defaults to all true as per spec @@ -370,15 +410,8 @@ createDoc file languageId contents = do createHits (WatchKind create _ _) = create - regHits :: Registration -> Bool - regHits reg = isJust $ do - opts <- reg ^. registerOptions - fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of - Success x -> Just x - Error _ -> Nothing - if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers) - then Just () - else Nothing + regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers) clientCapsSupports = caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just @@ -461,17 +494,17 @@ noDiagnostics = do -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) getDocumentSymbols doc = do - ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse + ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) :: Session DocumentSymbolsResponse case res of - Right (DSDocumentSymbols (List xs)) -> return (Left xs) - Right (DSSymbolInformation (List xs)) -> return (Right xs) + Right (L (List xs)) -> return (Left xs) + Right (R (List xs)) -> return (Right xs) Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) -- | Returns the code actions in the specified range. -getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult] +getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getCodeActions doc range = do ctx <- getCodeActionContext doc - rsp <- request STextDocumentCodeAction (CodeActionParams doc range ctx Nothing) + rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) case rsp ^. result of Right (List xs) -> return xs @@ -480,16 +513,16 @@ getCodeActions doc range = do -- | Returns all the code actions in a document by -- querying the code actions at each of the current -- diagnostics' positions. -getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult] +getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] getAllCodeActions doc = do ctx <- getCodeActionContext doc foldM (go ctx) [] =<< getCurrentDiagnostics doc where - go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] + go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] go ctx acc diag = do - ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) + ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx) case res of Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) @@ -509,7 +542,7 @@ getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args Nothing + execParams = ExecuteCommandParams Nothing (cmd ^. command) args request_ SWorkspaceExecuteCommand execParams -- | Executes a code action. @@ -524,7 +557,7 @@ 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) SWorkspaceApplyEdit (ApplyWorkspaceEditParams e) + let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) in updateState (FromServerMess SWorkspaceApplyEdit req) -- | Adds the current version to the document, as tracked by the session. @@ -546,9 +579,9 @@ applyEdit doc edit = do caps <- asks sessionCapabilities let supportsDocChanges = fromMaybe False $ do - let mWorkspace = C._workspace caps + let mWorkspace = caps ^. LSP.workspace C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace - C.WorkspaceEditClientCapabilities mDocChanges <- mEdit + C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit mDocChanges let wEdit = if supportsDocChanges @@ -559,7 +592,7 @@ applyEdit doc edit = do let changes = HashMap.singleton (doc ^. uri) (List [edit]) in WorkspaceEdit (Just changes) Nothing - let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SWorkspaceApplyEdit req) -- version may have changed @@ -568,11 +601,11 @@ applyEdit doc edit = do -- | Returns the completions for the position in the document. getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getCompletions doc pos = do - rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing) + rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) case getResponseResult rsp of - Completions (List items) -> return items - CompletionList (CompletionListType _ (List items)) -> return items + L (List items) -> return items + R (CompletionList _ (List items)) -> return items -- | Returns the references for the position in the document. getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. @@ -581,50 +614,71 @@ getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. -> Session (List Location) -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl - params = ReferenceParams doc pos ctx Nothing + params = ReferenceParams doc pos Nothing Nothing ctx in getResponseResult <$> request STextDocumentReferences params +-- | Returns the declarations(s) for the term at the specified position. +getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in. + -> Position -- ^ The position the term is at. + -> Session ([Location] |? [LocationLink]) +getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams + -- | Returns the definition(s) for the term at the specified position. getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session [Location] -- ^ The location(s) of the definitions -getDefinitions doc pos = do - let params = TextDocumentPositionParams doc pos Nothing - rsp <- request STextDocumentDefinition params :: Session DefinitionResponse - case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs + -> Session ([Location] |? [LocationLink]) +getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams -- | Returns the type definition(s) for the term at the specified position. getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session [Location] -- ^ The location(s) of the definitions -getTypeDefinitions doc pos = do - let params = TextDocumentPositionParams doc pos Nothing - rsp <- request STextDocumentTypeDefinition params :: Session TypeDefinitionResponse + -> Session ([Location] |? [LocationLink]) +getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams + +-- | Returns the type definition(s) for the term at the specified position. +getImplementations :: TextDocumentIdentifier -- ^ The document the term is in. + -> Position -- ^ The position the term is at. + -> Session ([Location] |? [LocationLink]) +getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams + + +getDeclarationyRequest :: (ResponseParams m ~ (Location |? (List Location |? List LocationLink))) + => SClientMethod m + -> (TextDocumentIdentifier + -> Position + -> Maybe ProgressToken + -> Maybe ProgressToken + -> MessageParams m) + -> TextDocumentIdentifier + -> Position + -> Session ([Location] |? [LocationLink]) +getDeclarationyRequest method paramCons doc pos = do + let params = paramCons doc pos Nothing Nothing + rsp <- request method params case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs + L loc -> pure (L [loc]) + R (L (List locs)) -> pure (L locs) + R (R (List locLinks)) -> pure (R locLinks) -- | Renames the term at the specified position. rename :: TextDocumentIdentifier -> Position -> String -> Session () rename doc pos newName = do - let params = RenameParams doc pos (T.pack newName) Nothing + let params = RenameParams doc pos Nothing (T.pack newName) rsp <- request STextDocumentRename params :: Session RenameResponse let wEdit = getResponseResult rsp - req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SWorkspaceApplyEdit req) -- | Returns the hover information at the specified position. -getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) +getHover :: TextDocumentIdentifier -> Position -> Session Hover getHover doc pos = - let params = TextDocumentPositionParams doc pos Nothing + let params = HoverParams doc pos Nothing in getResponseResult <$> request STextDocumentHover params -- | Returns the highlighted occurences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight) getHighlights doc pos = - let params = TextDocumentPositionParams doc pos Nothing + let params = DocumentHighlightParams doc pos Nothing Nothing in getResponseResult <$> request STextDocumentDocumentHighlight params -- | Checks the response for errors and throws an exception if needed. @@ -638,14 +692,14 @@ getResponseResult rsp = -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () formatDoc doc opts = do - let params = DocumentFormattingParams doc opts Nothing + let params = DocumentFormattingParams Nothing doc opts edits <- getResponseResult <$> request STextDocumentFormatting params applyTextEdits doc edits -- | Applies formatting to the specified range in a document. formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () formatRange doc opts range = do - let params = DocumentRangeFormattingParams doc range opts Nothing + let params = DocumentRangeFormattingParams Nothing doc range opts edits <- getResponseResult <$> request STextDocumentRangeFormatting params applyTextEdits doc edits @@ -653,13 +707,13 @@ applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () applyTextEdits doc edits = let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing -- Send a dummy message to updateState so it can do bookkeeping - req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) in updateState (FromServerMess SWorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do - rsp <- request STextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse + rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res @@ -667,5 +721,5 @@ getCodeLenses tId = do -- register during the 'Session'. -- -- @since 0.11.0.0 -getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get