From c7db2307c2d3dcc310fa5241756c2fbca7d00eea Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 28 Aug 2020 16:12:33 +0100 Subject: [PATCH] Add runSessionWithHandles Also update to strongly typed registration and add new declaration-y requests --- src/Language/Haskell/LSP/Test.hs | 141 +++++++++++++++-------- src/Language/Haskell/LSP/Test/Compat.hs | 7 +- src/Language/Haskell/LSP/Test/Session.hs | 24 ++-- 3 files changed, 112 insertions(+), 60 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index c14eb44..8dd252c 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -25,8 +25,9 @@ module Language.Haskell.LSP.Test -- * Sessions Session , runSession - -- ** Config , runSessionWithConfig + , runSessionWithHandles + -- ** Config , SessionConfig(..) , defaultConfig , C.fullCaps @@ -73,8 +74,10 @@ module Language.Haskell.LSP.Test -- ** References , getReferences -- ** Definitions + , getDeclarations , getDefinitions , getTypeDefinitions + , getImplementations -- ** Renaming , rename -- ** Hover @@ -122,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. @@ -147,20 +151,45 @@ 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 + + +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 + 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 @@ -192,7 +221,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 Empty) + exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit Empty -- | Listens to the server output until the shutdown ack, -- makes sure it matches the record and signals any semaphores @@ -202,7 +231,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do reqMap <- readMVar $ requestMap context - let msg = decodeFromServerMsg reqMap msgBytes + let msg = fst $ decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) case msg of @@ -356,8 +385,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 @@ -371,15 +402,8 @@ createDoc file languageId contents = do createHits (WatchKind create _ _) = create - regHits :: SomeRegistration -> 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 @@ -462,7 +486,7 @@ 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 (L (List xs)) -> return (Left xs) Right (R (List xs)) -> return (Right xs) @@ -472,7 +496,7 @@ getDocumentSymbols doc = do 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 @@ -490,7 +514,7 @@ getAllCodeActions doc = do where 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) @@ -510,7 +534,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. @@ -525,7 +549,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. @@ -549,7 +573,7 @@ applyEdit doc edit = do let supportsDocChanges = fromMaybe False $ do let mWorkspace = caps ^. LSP.workspace C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace - C.WorkspaceEditClientCapabilities mDocChanges <- mEdit + C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit mDocChanges let wEdit = if supportsDocChanges @@ -560,7 +584,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 @@ -569,7 +593,7 @@ 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 L (List items) -> return items @@ -582,50 +606,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 - L loc -> pure [loc] - R 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 |? List Location |? List LocationLink) -- ^ The location(s) of the definitions -getTypeDefinitions doc pos = - 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 - L loc -> pure [loc] - R 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. @@ -639,14 +684,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 @@ -654,13 +699,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 diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs index 883bfc9..12031c3 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, OverloadedStrings #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO @@ -7,6 +7,7 @@ module Language.Haskell.LSP.Test.Compat where import Data.Maybe import System.IO +import Language.Haskell.LSP.Types #if MIN_VERSION_process(1,6,3) -- We have to hide cleanupProcess for process-1.6.3.0 @@ -113,3 +114,7 @@ withCreateProcess c action = (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) #endif + + +lspTestClientInfo :: ClientInfo +lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION) diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 3e9e688..f9444f6 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -14,7 +14,7 @@ module Language.Haskell.LSP.Test.Session , SessionMessage(..) , SessionContext(..) , SessionState(..) - , runSessionWithHandles + , runSession' , get , put , modify @@ -201,8 +201,8 @@ instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m) get = lift get put = lift . put -runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state (Session session) = runReaderT (runStateT conduit state) context +runSessionasdf :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSessionasdf context state (Session session) = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) @@ -232,9 +232,9 @@ runSession context state (Session session) = runReaderT (runStateT conduit state -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. -runSessionWithHandles :: Handle -- ^ Server in +runSession' :: Handle -- ^ Server in -> Handle -- ^ Server out - -> ProcessHandle -- ^ Server process + -> Maybe ProcessHandle -- ^ Server process -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> ClientCapabilities @@ -242,7 +242,7 @@ runSessionWithHandles :: Handle -- ^ Server in -> Session () -- ^ To exit the Server properly -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do +runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -261,7 +261,7 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps initState vfs = SessionState 0 vfs mempty False Nothing mempty - runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses + runSession' ses = initVFS $ \vfs -> runSessionasdf context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher = @@ -269,20 +269,22 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro server = (Just serverIn, Just serverOut, Nothing, serverProc) msgTimeoutMs = messageTimeout config * 10^6 serverAndListenerFinalizer tid = do + let cleanup + | Just sp <- mServerProc = cleanupProcess (Just serverIn, Just serverOut, Nothing, sp) + | otherwise = pure () finally (timeout msgTimeoutMs (runSession' exitServer)) $ do -- Make sure to kill the listener first, before closing -- handles etc via cleanupProcess killThread tid -- Give the server some time to exit cleanly - -- It makes the server hangs in windows so we have to avoid it #ifndef mingw32_HOST_OS timeout msgTimeoutMs (waitForProcess serverProc) #endif - cleanupProcess server + cleanup (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer - (const $ initVFS $ \vfs -> runSession context (initState vfs) session) + (const $ initVFS $ \vfs -> runSessionasdf context (initState vfs) session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -300,7 +302,7 @@ updateState (FromServerMess SClientRegisterCapability req) = do s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } updateState (FromServerMess SClientUnregisterCapability req) = do - let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations + let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations modify $ \s -> let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs in s { curDynCaps = newCurDynCaps } -- 2.30.2